├── MANIFEST.SKIP ├── .gitignore ├── TODO ├── t ├── nickname.t ├── evolution.vcf ├── quotedprintable.vcf ├── quoted.vcf ├── label.t ├── label.vcf ├── apple_2.1_unicode.vcf ├── encoding.vcf ├── escape.t ├── simple.vcf ├── nickname.vcf ├── types.t ├── notes.vcf ├── mix_type.vcf ├── apple_version3.vcf ├── 06a-encoding2.t ├── encoding2.vcf ├── latin1.vcf ├── complete.vcf ├── text │ └── vcard │ │ └── node │ │ └── add_types.t ├── 07-quoted.t ├── unwrap.vcf ├── 06-encoding.t ├── unwrap.t ├── 04-formats.t ├── import-export.t ├── base64.vcf ├── 03-addressbook.t ├── 05-export.t ├── 08-base64.t ├── vcard │ └── address_book.t ├── 02-vcard.t ├── vcard.t └── 01-node.t ├── dist.ini ├── .travis.yml ├── lib ├── vCard │ ├── Role │ │ └── FileIO.pm │ └── AddressBook.pm ├── Text │ ├── vCard │ │ ├── Addressbook.pm │ │ └── Node.pm │ └── vCard.pm └── vCard.pm ├── README.md └── Changes /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | dist.ini 2 | TODO 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | syntax: glob 2 | MYMETA.json 3 | MYMETA.yml 4 | Makefile 5 | Text-vCard-* 6 | blib 7 | pm_to_blib 8 | *.swp 9 | 10 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Addressbook: 2 | 3 | Work out the escape stuff for export() 4 | 5 | find() 6 | - get vcards matching specific criteria 7 | 8 | overall: 9 | - better doc examples 10 | 11 | -------------------------------------------------------------------------------- /t/nickname.t: -------------------------------------------------------------------------------- 1 | use vCard; 2 | use Test::Most; 3 | 4 | my $vcard = vCard->new; 5 | my $nickname = $vcard->load_file( 't/nickname.vcf' )->nickname(); 6 | ok($nickname, 'T-nickname'); 7 | done_testing; 8 | -------------------------------------------------------------------------------- /t/evolution.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | X-EVOLUTION-FILE-AS:Sister 4 | FN:T-firstname T-surname 5 | N:;Sister;;; 6 | TEL;HOME:020 666 6666 7 | UID:pas-id-3EDER42342390 8 | END:VCARD 9 | 10 | -------------------------------------------------------------------------------- /t/quotedprintable.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | N;CHARSET=utf-8;ENCODING=quoted-printable:Gau=C3=9F;Carl;;; 4 | FN;CHARSET=utf-8;ENCODING=quoted-printable:Carl Gau=C3=9F 5 | TEL;TYPE=voice:+471112345 6 | END:VCARD 7 | -------------------------------------------------------------------------------- /t/quoted.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | N:Smith;John;;; 4 | ADR;ENCODING=QUOTED-PRINTABLE;CHARSET=UTF-8:= 5 | ;;A street on a quoted line;Some test town;Some test region;0815;=C3=96= 6 | sterreich 7 | FN:John Smith 8 | END:VCARD 9 | 10 | -------------------------------------------------------------------------------- /t/label.t: -------------------------------------------------------------------------------- 1 | use Test::Most; 2 | use Text::vCard::Addressbook; 3 | 4 | my $address_book = Text::vCard::Addressbook->load( ['t/label.vcf'] ); 5 | my $address = $address_book->vcards->[0]->get('ADR')->[0]->label(); 6 | ok( $address, "422 S. New Lane\\nStoughton, MA 02072\\nUS" ); 7 | done_testing; 8 | -------------------------------------------------------------------------------- /t/label.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:3.0 3 | FN:Joe Bloggs 4 | N:Bloggs;Joe;;; 5 | item1.EMAIL;TYPE=INTERNET:joe.bloggs@joebloggs.com 6 | item1.X-ABLabel: 7 | item2.ADR:;;422 S. New Lane;Stoughton;MA;02072;US;422 S. New Lane\nStoughto 8 | n\, MA 02072\nUS 9 | item2.X-ABLabel: 10 | CATEGORIES:myContacts 11 | END:VCARD 12 | -------------------------------------------------------------------------------- /t/apple_2.1_unicode.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | N:T-surname;T-first;;; 4 | FN:T-firstname T-surname 5 | TEL;HOME:020 666 6666 6 | TEL;CELL:0777 - 777 7777 7 | ADR;HOME:;;Pref Test Road;Pref Test City;;Pref Test Postcode;Pref Test Country 8 | ADR;WORK:;;Test Road;Test City;;Test Postcode;Test Country 9 | END:VCARD 10 | -------------------------------------------------------------------------------- /t/encoding.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | N:Christiansen;Nathan;Paul;Mr.;I 4 | FN:Nathan Paul Christiansen I 5 | NICKNAME:The Professor 6 | TEL;WORK;FAX:(801) 234-1001 7 | ADR;WORK;ENCODING=QUOTED-PRINTABLE:;Corporate;Software Development=0D=0A333 West River Park Drive;Provo;UT;8460= 8 | 4;United States of America 9 | END:VCARD 10 | -------------------------------------------------------------------------------- /t/escape.t: -------------------------------------------------------------------------------- 1 | use Test::Most; 2 | use Text::vCard::Addressbook; 3 | use Path::Tiny; 4 | 5 | my $in_file = path('t/complete.vcf'); 6 | my $address_book = Text::vCard::Addressbook->load( [$in_file] ); 7 | my $vcard = $address_book->vcards->[0]; 8 | is $vcard->fullname, 'Bruce Banner, PhD', ', was not escaped'; 9 | 10 | done_testing; 11 | -------------------------------------------------------------------------------- /t/simple.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | N:T-surname;T-firstname;;; 4 | FN:T-firstname T-surname 5 | TEL;TYPE=HOME:020 666 6666 6 | TEL;TYPE=CELL:0793 777 7777 7 | ADR;TYPE=HOME:;;Test Road;Test City;;Test Postcode;Test Country 8 | ADR;TYPE=HOME,PREF:;;Pref Test Road;Pref Test City;;Pref Test Postcode;Pref Test Country 9 | END:VCARD 10 | -------------------------------------------------------------------------------- /t/nickname.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | N:T-surname;T-firstname;;; 4 | FN:T-firstname T-surname 5 | NICKNAME:T-nickname 6 | TEL;TYPE=HOME:020 666 6666 7 | TEL;TYPE=CELL:0793 777 7777 8 | ADR;TYPE=HOME:;;Test Road;Test City;;Test Postcode;Test Country 9 | ADR;TYPE=HOME,PREF:;;Pref Test Road;Pref Test City;;Pref Test Postcode;Pref Test Country 10 | END:VCARD 11 | -------------------------------------------------------------------------------- /t/types.t: -------------------------------------------------------------------------------- 1 | use Test::Most; 2 | use Text::vCard::Addressbook; 3 | 4 | my $address_book = Text::vCard::Addressbook->load( ['t/complete.vcf'] ); 5 | my $vcard = $address_book->vcards->[0]; 6 | my $phone_node = $vcard->get( { 'node_type' => 'phones' } )->[1]; 7 | my $types = $phone_node->types; 8 | is_deeply $types, [ 'cell', 'text' ], 'types()'; 9 | 10 | done_testing; 11 | -------------------------------------------------------------------------------- /t/notes.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:3.0 3 | N:;;;; 4 | FN:Test 5 | ORG:Test; 6 | TEL;type=WORK;type=pref:123/1234123 7 | item1.ADR;type=WORK;type=pref:;;12a The Street.;Montreal;Quebec;;Canada 8 | item1.X-ABADR:ca 9 | NOTE:@prefix nasty \; with \; added into it and\n@prefix del: \n"\; ]]\;\n]\;\n. 10 | X-ABShowAs:COMPANY 11 | CATEGORY:montreal 12 | END:VCARD 13 | 14 | -------------------------------------------------------------------------------- /t/mix_type.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | N:T-surname;T-firstname;;; 4 | FN:T-firstname T-surname 5 | TEL;TYPE=HOME:020 666 6666 6 | TEL;TYPE=CELL:0793 777 7777 7 | ADR;TYPE=HOME:;;Test Road;Test City;;Test Postcode;Test Country 8 | ADR;TYPE=HOME,PREF:;;Pref Test Road;Pref Test City;;Pref Test Postcode;Pref Test Country 9 | END:VCARD 10 | BEGIN:FOO 11 | VERSION:2.1 12 | END:FOO 13 | -------------------------------------------------------------------------------- /t/apple_version3.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:3.0 3 | N:T-surname;T-first;;; 4 | FN:T-firstname T-surname 5 | TEL;type=HOME;type=pref:020 666 6666 6 | TEL;CELL:0777 777 7777 7 | item1.ADR;type=HOME;type=pref:;;Pref Test Road;Pref Test City;;Pref Test Postcode;Pref Test Country 8 | item1.X-ABADR:uk 9 | item2.ADR;type=WORK:;;Test Road;Test City;;Test Postcode;Test Country 10 | item2.X-ABADR:uk 11 | END:VCARD 12 | -------------------------------------------------------------------------------- /t/06a-encoding2.t: -------------------------------------------------------------------------------- 1 | use Test::Most; 2 | use lib 'lib'; 3 | 4 | use Text::vCard::Addressbook; 5 | 6 | my $card_type = 'encoding2.vcf'; 7 | 8 | my $address_book = Text::vCard::Addressbook # 9 | ->new( { source_file => "t/$card_type" } ); 10 | 11 | foreach my $vcard ( $address_book->vcards() ) { 12 | my $string = $vcard->as_string(); 13 | ok $string !~ /Gau=C3=83=C2=9F/, "no double encoding"; 14 | } 15 | 16 | done_testing; 17 | -------------------------------------------------------------------------------- /t/encoding2.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | FN;ENCODING=QUOTED-PRINTABLE;CHARSET=utf-8:Bartholom=C3=A4us von St=C3=BCrm= 4 | er 5 | N;ENCODING=QUOTED-PRINTABLE;CHARSET=utf-8:von St=C3=BCrmer;Bartholom=C3=A4u= 6 | s;;; 7 | TEL;CELL:+08154711 8 | END:VCARD 9 | BEGIN:VCARD 10 | VERSION:2.1 11 | FN;ENCODING=QUOTED-PRINTABLE;CHARSET=utf-8:Carl Gau=C3=9F 12 | N;ENCODING=QUOTED-PRINTABLE;CHARSET=utf-8:Gau=C3=9F;Carl;;; 13 | TEL;VOICE:+471112345 14 | END:VCARD 15 | -------------------------------------------------------------------------------- /t/latin1.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | FN:Bruce Banner\, PhD 3 | ADR;TYPE=home:;;Main St;Desert Base;New Mexico;55416;USA 4 | ADR;TYPE=work:;;Army St;Desert Base;New Mexico;55416;USA 5 | BDAY:19700414 6 | EMAIL;PREF=1;TYPE=work:bbanner.work@example.com 7 | EMAIL;TYPE=home:bbanner.home@example.com 8 | PHOTO:http://shh.supersecret.army.mil/bbanner.gif 9 | TEL;PREF=1;TYPE=work:651-290-1234 10 | TEL;TYPE=cell,text:651-290-1111 11 | TITLE:Research Scientist 12 | TZ:UTC-7 13 | END:VCARD 14 | -------------------------------------------------------------------------------- /t/complete.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:4.0 3 | N:Banner;Bruce;;Dr.;PhD 4 | FN:Bruce Banner\, PhD 5 | ADR;TYPE=home:;;Main St;Desert Base;New Mexico;55416;USA 6 | ADR;TYPE=work:;;部队街;Desert Base;New Mexico;55416;USA 7 | BDAY:19700414 8 | EMAIL;PREF=1;TYPE=work:bbanner.work@example.com 9 | EMAIL;TYPE=home:bbanner.home@example.com 10 | PHOTO:http://shh.supersecret.army.mil/bbanner.gif 11 | TEL;PREF=1;TYPE=work:651-290-1234 12 | TEL;TYPE=cell,text:651-290-1111 13 | TITLE:Research Scientist 14 | TZ:UTC-7 15 | END:VCARD 16 | -------------------------------------------------------------------------------- /t/text/vcard/node/add_types.t: -------------------------------------------------------------------------------- 1 | use Test::Most; 2 | use Text::vCard::Addressbook; 3 | 4 | my $address_book = Text::vCard::Addressbook->new; 5 | my $vcard = $address_book->add_vcard(); 6 | $vcard->version('2.07'); 7 | $vcard->fullname("My Name"); 8 | 9 | my $mail_node = $vcard->add_node({'node_type' => 'EMAIL'}); 10 | $mail_node->add_types('INTERNET'); 11 | $mail_node->value( "john\@example.org" ); 12 | 13 | my $string = $address_book->export; 14 | 15 | like $string, qr/TYPE=internet/, 'add_types() works'; 16 | 17 | done_testing; 18 | -------------------------------------------------------------------------------- /t/07-quoted.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | 5 | use lib qw(./lib); 6 | 7 | use Test::More tests => 3; 8 | 9 | BEGIN { use_ok('Text::vCard::Addressbook'); } 10 | 11 | my $address_book 12 | = Text::vCard::Addressbook->new( { 'source_file' => 't/quoted.vcf', } ); 13 | 14 | ok( $address_book, "Got an address book object" ); 15 | 16 | foreach my $vcard ( $address_book->vcards() ) { 17 | my $addresses = $vcard->get( { 'node_type' => 'ADR' } ); 18 | foreach my $address ( @{$addresses} ) { 19 | is( $address->street(), 20 | 'A street on a quoted line', 21 | 'Got full (quoted address)' 22 | ); 23 | } 24 | } 25 | 26 | -------------------------------------------------------------------------------- /t/unwrap.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:2.1 3 | N;CHARSET=utf-8;ENCODING=quoted-printable:mynameisveryveryveryveryveryvery= 4 | long 5 | FN:Bruce Banner\, PhD 6 | ADR;TYPE=home:;;Hover Valley Mountain Pass Road;Desert Base;New Mexico;5541 7 | 6;USA 8 | BDAY:19700414 9 | EMAIL;PREF=1;TYPE=work:bbanner.work@example.com 10 | EMAIL;TYPE=home:bbanner.home@example.com 11 | PHOTO:http://shh.supersecret.army.mil/bbanner.gif 12 | TEL;PREF=1;TYPE=work:651-290-1234 13 | TEL;TYPE=cell,text:651-290-1111 14 | TITLE:Research Scientist 15 | TZ:UTC-7 16 | NOTE:致死量のガンマ線を浴びたはずが生還したバナー。 17 | しかし、バナーの体にある変化が起きていた。怒りや 18 | 憎しみなど、負の感情の高ぶりによって、緑色の肌と 19 | 人間離れした怪力を持つ巨人«ハルク»に変身する体質 20 | となってしまっていたのだ。何もしなければおとなし 21 | いバナーは、少しでも危害を加えられると怒りに身を 22 | 任せてハルクとして暴れまわり、圧倒的なパワーであ 23 | りとあらゆる物を破壊してしまう。 24 | END:VCARD 25 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Text-vCard 2 | license = Perl_5 3 | copyright_year = 2015 4 | author = Leo Lapworth 5 | author = Eric Johnson (kablamo) 6 | copyright_holder = Leo Lapworth 7 | version = 3.09 8 | 9 | [@Basic] 10 | [InstallGuide] 11 | [MetaJSON] 12 | [PkgVersion] 13 | [ReadmeAnyFromPod] 14 | type = markdown 15 | filename = README.md 16 | location = root 17 | source_filename = lib/vCard.pm 18 | 19 | [MetaResources] 20 | bugtracker.web = https://github.com/ranguard/text-vcard/issues 21 | repository.url = https://github.com/ranguard/text-vcard 22 | repository.web = https://github.com/ranguard/text-vcard 23 | repository.type = git 24 | 25 | [NoTabsTests] 26 | ; [EOLTests] 27 | ; [PodCoverageTests] 28 | [PodSyntaxTests] 29 | 30 | [AutoPrereqs] 31 | -------------------------------------------------------------------------------- /t/06-encoding.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | 5 | use lib qw(./lib); 6 | 7 | use Test::More tests => 7; 8 | 9 | # Check we can load module 10 | BEGIN { use_ok('Text::vCard::Addressbook'); } 11 | 12 | my $card_type = 'encoding.vcf'; 13 | 14 | ok( $card_type, "Running from $card_type" ); 15 | my $adbk = Text::vCard::Addressbook->new( { source_file => "t/$card_type" } ); 16 | isa_ok( $adbk, 'Text::vCard::Addressbook' ); 17 | my $vcards = $adbk->vcards(); 18 | 19 | is( scalar( @{$vcards} ), 1, "$card_type has 1 vcards as expected" ); 20 | my $vcard = $vcards->[0]; 21 | is( $vcard->get('fn')->[0]->value(), 22 | 'Nathan Paul Christiansen I', 23 | "$card_type has fn data correct" 24 | ); 25 | 26 | # print Dumper($vcard); 27 | my $a = $vcard->get( 28 | { 'node_type' => 'ADR', 29 | 'types' => 'work', 30 | } 31 | )->[0]; 32 | is( $a->street(), 33 | "Software Development\x0D\x0A333 West River Park Drive", 34 | 'Match on street' 35 | ); 36 | is( $a->city(), 'Provo', 'Match on city' ); 37 | 38 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | perl: 3 | - "5.24" 4 | - "5.22" 5 | - "5.20" 6 | - "5.18" 7 | - "5.16" 8 | - "5.14" 9 | - "5.12" 10 | - "5.10" 11 | - "5.8" 12 | 13 | env: 14 | global: 15 | - stableperl=5.24 16 | 17 | before_install: 18 | - perlbrew list 19 | - "perlbrew exec --with $stableperl 'cpanm --quiet --notest Dist::Zilla'" 20 | - "perlbrew exec --with $stableperl 'dzil authordeps | cpanm --quiet --notest'" 21 | - "perlbrew exec --with $stableperl 'dzil build --in $builddir'" 22 | 23 | install: 24 | - cpanm --quiet --notest --installdeps --skip-satisfied Dist::Zilla 25 | - cpanm Test::NoTabs 26 | - "dzil authordeps | grep -vP '[^\\w:]' | cpanm --verbose --notest --skip-satisfied" 27 | - "dzil listdeps | grep -vP '[^\\w:]' | cpanm --verbose --skip-satisfied" 28 | 29 | script: 30 | - "perlbrew exec --with $stableperl 'dzil smoke --release --author'" 31 | 32 | notifications: 33 | email: 34 | recipients: 35 | - llap@cpan.org 36 | on_success: change 37 | on_failure: always 38 | -------------------------------------------------------------------------------- /lib/vCard/Role/FileIO.pm: -------------------------------------------------------------------------------- 1 | package vCard::Role::FileIO; 2 | 3 | use Moo::Role; 4 | use Path::Tiny; 5 | 6 | requires qw/encoding_in encoding_out/; 7 | 8 | # PerlIO layers should look like ':encoding(UTF-8)' 9 | # The ':encoding()' part does character set and encoding transformations. 10 | # Without it you are just declaring the stream to be of a certain encoding. 11 | # See PerlIO, PerlIO::encoding docs. 12 | 13 | sub _iomode_out { 14 | my ($self) = @_; 15 | return { binmode => ':raw' } if $self->encoding_out eq 'none'; 16 | return { binmode => ':raw:encoding(' . $self->encoding_out . ')' }; 17 | } 18 | 19 | sub _iomode_in { 20 | my ($self) = @_; 21 | return { binmode => ':raw' } if $self->encoding_in eq 'none'; 22 | return { binmode => ':raw:encoding(' . $self->encoding_in . ')' }; 23 | } 24 | 25 | # Filename can be a string, a Path::Tiny obj, or a Path::Class obj. 26 | # Returns a Path::Tiny obj. 27 | sub _path { 28 | my ( $self, $filename ) = @_; 29 | return ref $filename eq 'Path::Class::File' # 30 | ? path("$filename") 31 | : path($filename); # works for strings and Path::Tiny objects 32 | } 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /t/unwrap.t: -------------------------------------------------------------------------------- 1 | use Test::Most; 2 | 3 | use Path::Tiny; 4 | use vCard; 5 | 6 | # vCard files should have lines that are a max of 75 octets. When they are too 7 | # long the lines are wrapped. The first character on continued line must be a 8 | # space or a tab. This test makes sure that works. 9 | # see http://tools.ietf.org/search/rfc6350#section-3.2 10 | 11 | my $in_file = path( 't', 'unwrap.vcf' ); 12 | note "Importing $in_file with Addressbook->load()"; 13 | 14 | my $address_book = Text::vCard::Addressbook->load( [$in_file] ); 15 | my $vcard = $address_book->vcards->[0]; 16 | 17 | my $expected_content = $in_file->slurp_utf8; 18 | my $actual_content = $vcard->as_string(); 19 | 20 | # the order in the vcard keys is not preserved so we wil test the only the wrapped lines 21 | my $N = qr(/(N;CH[^\r]\r\n(?:[ \t][^\r]*\r\n)*)/s); 22 | my $ADR = qr(/(ADR;[^\r]\r\n(?:[ \t][^\r]*\r\n)*)/s); 23 | my $NOTE = qr(/(NOTE[^\r]\r\n(?:[ \t][^\r]*\r\n)*)/s); 24 | 25 | 26 | is $actual_content =~ $N,$expected_content =~ $N, 'vCard->as_string() N ?'; 27 | is $actual_content =~ $ADR,$expected_content =~ $ADR, 'vCard->as_string() ADR key?'; 28 | is $actual_content =~ $NOTE,$expected_content =~ $NOTE, 'vCard->as_string() NOTE key?'; 29 | 30 | is $address_book->export(), $actual_content, 'Addressbook->export()'; 31 | 32 | done_testing; 33 | -------------------------------------------------------------------------------- /t/04-formats.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | 5 | use lib qw(./lib); 6 | 7 | use Test::More tests => 17; 8 | 9 | # Check we can load module 10 | use Data::Dumper; 11 | BEGIN { use_ok('Text::vCard::Addressbook'); } 12 | 13 | my @card_types = qw(evolution.vcf apple_2.1_unicode.vcf apple_version3.vcf); 14 | 15 | foreach my $card_type (@card_types) { 16 | ok( $card_type, "Running from $card_type" ); 17 | my $adbk 18 | = Text::vCard::Addressbook->new( { source_file => "t/$card_type" } ); 19 | isa_ok( $adbk, 'Text::vCard::Addressbook' ); 20 | my $vcards = $adbk->vcards(); 21 | 22 | is( scalar( @{$vcards} ), 1, "$card_type has 1 vcards as expected" ); 23 | my $vcard = $vcards->[0]; 24 | is( $vcard->get('fn')->[0]->value(), 25 | 'T-firstname T-surname', 26 | "$card_type has fn data correct" 27 | ); 28 | 29 | # print Dumper($vcard); 30 | my $t = $vcard->get( 31 | { 'node_type' => 'tel', 32 | 'types' => 'home', 33 | } 34 | ); 35 | is( $t->[0]->value(), '020 666 6666', 'got expected phone number' ); 36 | } 37 | 38 | my $adbk = Text::vCard::Addressbook->new( { source_file => "t/notes.vcf" } ); 39 | my $vcards = $adbk->vcards(); 40 | my $note = $vcards->[0]->note; 41 | is( $note, 42 | '@prefix nasty ; with ; added into it and\n@prefix del: \n"; ]];\n];\n.', 43 | 'Got note ok' 44 | ); 45 | 46 | -------------------------------------------------------------------------------- /t/import-export.t: -------------------------------------------------------------------------------- 1 | use Test::Most; 2 | use Text::vCard::Addressbook; 3 | use Path::Tiny; 4 | 5 | # This test makes sure that the files we export are the same as what we 6 | # imported. This property is not true for every possible vcard, but it should 7 | # always be true for the vcards that are tested below. 8 | 9 | note "utf-8 encoded files"; 10 | foreach my $filename (qw|complete.vcf quotedprintable.vcf|) { 11 | note "Importing $filename with Addressbook->load()"; 12 | my $in_file = path( 't', $filename ); 13 | 14 | # load() uses ':encoding('UTF-8')' by default to slurp $in_file 15 | my $address_book = Text::vCard::Addressbook->load( [$in_file] ); 16 | my $vcard = $address_book->vcards->[0]; 17 | 18 | # This returns UTF-8 decoded content 19 | my $expected_content = $in_file->slurp_utf8; 20 | 21 | # This returns UTF-8 decoded content 22 | my $actual_content = $vcard->as_string(); 23 | 24 | # These are comparing 2 things that are both UTF-8 decoded 25 | is $actual_content, $expected_content, 'vCard->as_string()'; 26 | is $address_book->export(), $actual_content, 'Addressbook->export()'; 27 | } 28 | 29 | note "latin1 encoded files"; 30 | foreach my $filename (qw|latin1.vcf|) { 31 | note "Importing $filename with Addressbook->load()"; 32 | my $in_file = path( 't', $filename ); 33 | 34 | my $address_book = Text::vCard::Addressbook->load( [$in_file], 35 | { encoding_in => 'none', encoding_out => 'none' } ); 36 | my $vcard = $address_book->vcards->[0]; 37 | my $expected_content = $in_file->slurp_raw(); 38 | my $actual_content = $vcard->as_string(); 39 | 40 | is $actual_content, $expected_content, 'vCard->as_string()'; 41 | is $address_book->export(), $actual_content, 'Addressbook->export()'; 42 | } 43 | 44 | done_testing; 45 | -------------------------------------------------------------------------------- /t/base64.vcf: -------------------------------------------------------------------------------- 1 | BEGIN:VCARD 2 | VERSION:3.0 3 | N:Victory;Photo;;; 4 | FN:Photo Victory 5 | ORG:For Great Justice™;; 6 | PHOTO;ENCODING=b;TYPE=x-evolution-unknown:R0lGODlhlgAyALMPAAAAAP9BAP////9PA 7 | P//AP/xAP/ZAP//Vv//sP+KAP+gAP9tAP9fAP+wAP/LAP///yH5BAEAAA8ALAAAAACWADIAQAT 8 | /8MlJq7046827/2DIAYIAVGRpAiyaqvApvXAtP2xc3hO9W6QWhcbD1VRF49GEARCe0JPzmZxSg 9 | VZC8pLVoqDenlPY3fbA2myxnGFvAIp4nCXfwuWKNd4MxOdRe4B/OH58Yn6DgnVthR0AA5CRkXa 10 | SA2uSVUI9lZeTKJAyj5iOoqBcnG2ojgGsrQF8AK6sPLGyLLNNta9YraG6u7eytlW2vL1mwbOGI 11 | szNzs/Q0SFBM0s2LjY3PkuaYtfYPx85TFg+duNITQjrCLTrVeztXPHtUvViLADx8Oy+9zP05GH 12 | ZB7AfEHqwEGpgYaBhQ4YPuTiMOGTish4TDayxiIIigIzL/z5mdFgFZBuTbxaoVAlg5QI7Ll+ic 13 | HlxRsw1NGfKxHHTQ8uV3WzmbNJzlbBdXIoNcUUrFrFjKJguxTWD6cVfSKP2WijVJ9ZXmr4O8yU 14 | sKBCqZ4+CFaM2q1a3PY7akRstX7l8ZvHlvRvSbq6aLq76XTh4GrUZ25A05RbK2jfEMc49HhEDh 15 | bUql9sUxhFkTWUu2dJV4wY6XYrFkYEo7vGZdbbSqZscmD3bV20gtA/Yyb13CADeuGtruz0jN/H 16 | gtKUA920c2e/lTQpIny5FulkA0wtUyQ4YO3cU34dYn5FdO+Hy3seLD88F/QgH8OGziG8nvnwU9 17 | rvbd7AmP37+M+x31f9+/NXnXxMCjpDAgguywKAdDDaIQoTdRZjAGhROeOEMFtYEgIUbavggMh1 18 | 6yMCJDACAYopcrMjiECt25+IaMaJwYigz+lQjEDk20eMIlXhyyihDECmGJZ8YOYOSpYSiyhtPF 19 | qlkkkKOIBcyw0ylDGJwVbXVW1klo80veG2Gg1LSTKNWUPmUZVcyaCaFlpZgKSVWWWnN6WWcceH 20 | p1Za5ZMlFML35BouY5+hi5lK9IaoZVGlGKumklFbKmi/5HGEmOt2Uiddqg54mWaGgNTqOqaI2c 21 | xg6mQ1B2miOheONYpiB6oitkGmKxavTyMoZY5a1ymqrsOJarK+I1YpsYuS4yiv/CKcFi6xrxDJ 22 | bJrUrdCataM522tqxOygb264rdKsat75lE+1orGay2rrg2hEbEeCgm+63B/WjzTv58tuvv4viQ 23 | BAKAwsskMEFE6wvwgf3oJA6CSMnHA7JSbxbxSM05wLGxenWQ3PO8cYCdB0nhwzIC6HhhRVVgNF 24 | yFB6isYbLX4ThRhMyq1FzFG3I/EZ52rGgHnjUrcHez0fjkLR3obi3ENBFE01dG04vBJJIGknEU 25 | UUk+YQSRl1zHcrXuYykUUlbax32Qg203TYLbtvh9tsozN3d3A2sYXfdec+A91V45y333k38PUI 26 | hdyQyRCOLL+II4z0E0ngokC+ESCaV+5Y5/xcdZghEhyKGqKDnPZDOYYgfmq4Z6KGL/rnqudA0l 27 | E5A0b7TCEX1MLtQoeSeUu1A+G777W/EuKONx8+Q/EI/Ko8ijS+quHwb0+PQPPLP+xQkKJRMWQq 28 | Sn3RS5ZLjs2AKDlGmMiX541N5vpV0yflln3o6tQafZGpJ1vxcdQVmo1bxyZqagD//nek6BtyTW 29 | xRFPz3Jz4GcwQthJChAPz1wTljBy1ry1KX8KRBTbekgn5IVMBKSik6Q4iAG2wJACCqqTVC5Uwr 30 | pxKavnMOCb2AhPkKIlDsZglCDCuH+1oRAQKHQhfEzijLWAKdjMHGEvHCOm+43RQJu0AWCwmIAx 31 | VFCExiSioJpupZmupisN4DxLye0lBrXyEYPRAAAOw== 32 | REV:2012-09-06T01:57:22Z 33 | UID:pas-id-5048030200000000 34 | END:VCARD 35 | -------------------------------------------------------------------------------- /t/03-addressbook.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use Data::Dumper; 5 | 6 | use lib qw(./lib); 7 | 8 | use Test::More tests => 13; 9 | 10 | local $SIG{__WARN__} = sub { die $_[0] }; 11 | 12 | # Check we can load module 13 | BEGIN { use_ok('Text::vCard::Addressbook'); } 14 | 15 | ##### 16 | # load 17 | ##### 18 | my $load = Text::vCard::Addressbook->load( ['t/simple.vcf'] ); 19 | isa_ok( $load, 'Text::vCard::Addressbook' ); 20 | 21 | eval { Text::vCard::Addressbook->load( ['i/do/not/exist'] ); }; 22 | like( $@, qr/Unable to read file/, 23 | 'load() - croak when file does not exist' ); 24 | 25 | ###### 26 | # new() 27 | ###### 28 | 29 | # Can we create an empty address book 30 | my $newadbk = Text::vCard::Addressbook->new(); 31 | isa_ok( $newadbk, 'Text::vCard::Addressbook' ); 32 | 33 | eval { 34 | Text::vCard::Addressbook->new( { 'source_file' => 'i/do/not/exist' } ); 35 | }; 36 | like( $@, qr/Unable to read file/, 'new() - croak when unable to read file' ); 37 | 38 | eval { Text::vCard::Addressbook::new(undef); }; 39 | like( 40 | $@, 41 | qr/Use of uninitialized value/, 42 | 'new() - ok error when no proto supplied' 43 | ); 44 | 45 | my $foo = Text::vCard::Addressbook::new('foo::bar'); 46 | is( ref($foo), 'foo::bar', 'new() - Can use as a base class' ); 47 | 48 | my $hash = Text::vCard::Addressbook::new( { foo => 'bar' } ); 49 | is( ref($hash), 'HASH', 'new() - retruns HASH when supplied hash' ); 50 | 51 | eval { 52 | Text::vCard::Addressbook->new( { 'source_file' => 't/mix_type.vcf' } ); 53 | }; 54 | like( $@, qr/This file contains FOO/, 'new() - carp on non VCARD format' ); 55 | ##### 56 | # add_vcard() 57 | ##### 58 | # Create a new vCard 59 | my $vcard = $newadbk->add_vcard(); 60 | isa_ok( $vcard, 'Text::vCard' ); 61 | 62 | # Add a node to it 63 | my $address = $vcard->add_node( { 'node_type' => 'ADR', } ); 64 | 65 | # Add some data to the address. 66 | $address->street('19 The mews'); 67 | $address->city('Buffyvill'); 68 | 69 | ##### 70 | # vcards 71 | ##### 72 | # Now get it out of the address book 73 | my $card_a = $newadbk->vcards(); 74 | is( ref($card_a), 'ARRAY', 'vcards() - returns array ref when in context' ); 75 | is( $card_a->[0]->get( { 'node_type' => 'ADR' } )->[0]->street(), 76 | '19 The mews', 'exstracted address ok' ), 77 | 78 | my @vcard_list = $newadbk->vcards(); 79 | is( scalar(@vcard_list), 1, 'vcards() returns array when in context' ); 80 | 81 | -------------------------------------------------------------------------------- /t/05-export.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use Test::Most; 4 | use lib qw(./lib); 5 | use Data::Dumper; 6 | 7 | # Check we can load module 8 | BEGIN { use_ok('Text::vCard::Addressbook'); } 9 | 10 | local $SIG{__WARN__} = sub { die $_[0] }; 11 | 12 | ####### 13 | # Test new() 14 | ####### 15 | my $adbk = Text::vCard::Addressbook->new( 16 | { 'source_file' => 't/apple_version3.vcf' } ); 17 | 18 | my $vcf = $adbk->export(); 19 | 20 | like( $vcf, qr/TYPE=work/, 'export() - added type def' ); 21 | 22 | my @lines = split( "\x0D\x0A", $vcf ); # \x0D\x0A == \r\n 23 | 24 | is( $lines[0], 'BEGIN:VCARD', 'export() - First line correct' ); 25 | is( $lines[$#lines], 'END:VCARD', 'export() - Last line correct' ); 26 | 27 | $adbk->set_encoding('utf-8'); 28 | my @data = ( 29 | 'BEGIN:VCARD', 30 | 'item1.X-ABADR:uk', 31 | 'item2.X-ABADR:uk', 32 | 'N:T-surname;T-first;;;', 33 | 'TEL;TYPE=home,pref:020 666 6666', 34 | 'TEL;TYPE=cell:0777 777 7777', 35 | 'item2.ADR;TYPE=work:;;Test Road;Test City;;Test Postcode;Test Country', 36 | 'item1.ADR;TYPE=home,pref:;;Pref Test Road;Pref Test City;;Pref Test Postcod', 37 | ' e;Pref Test Country', 38 | 'VERSION:3.0', 39 | 'FN:T-firstname T-surname', 40 | 'END:VCARD', 41 | ); 42 | @lines = split( "\x0D\x0A", $adbk->export() ); # \x0D\x0A == \r\n 43 | is_deeply( 44 | [ sort @lines ], 45 | [ sort @data ], 46 | 'set_encoding() - returned data matched that expected' 47 | ); 48 | 49 | #is_deeply(\@lines,\@data,'export() - returned data matched that expected'); 50 | 51 | #my $notes = Text::vCard::Addressbook->new({ 'source_file' => 't/notes.vcf'}); 52 | #print Dumper($notes); 53 | #my $res = $notes->export(); 54 | #print Dumper($res); 55 | 56 | { 57 | my $ab = Text::vCard::Addressbook->new(); 58 | is $ab->export, '', 'export empty addressbook'; 59 | my $vcard = $ab->add_vcard; 60 | isa_ok $vcard, 'Text::vCard'; 61 | like $ab->export, qr{^BEGIN:VCARD\s+END:VCARD\x0D\x0A$}, 62 | 'single empty vcard'; 63 | $vcard->fullname('Foo Bar'); 64 | $vcard->EMAIL('foo@bar.com'); 65 | my $node = $vcard->add_node( 66 | { 'node_type' => 'TEL', 67 | 68 | # fields => ['TYPE'], 69 | # data => { TYPE => 'Work' }, 70 | } 71 | ); 72 | isa_ok $node, 'Text::vCard::Node'; 73 | 74 | #$vcard->TEL('01-23456789'); 75 | eval { $vcard->random_field('Something else'); }; 76 | like $@, 77 | qr{Can't locate object method "random_field" via package "Text::vCard"}, 78 | 'exception'; 79 | 80 | #diag $ab->export; 81 | } 82 | 83 | done_testing; 84 | -------------------------------------------------------------------------------- /t/08-base64.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More; 4 | use lib qw(./lib); 5 | use MIME::Base64; 6 | use Path::Tiny; 7 | 8 | BEGIN { use_ok('Text::vCard::Addressbook'); } 9 | 10 | my $address_book = Text::vCard::Addressbook # 11 | ->new( { 'source_file' => 't/base64.vcf', } ); 12 | 13 | ok( $address_book, "Got an address book object" ); 14 | 15 | my ($vcard) = ( $address_book->vcards ); 16 | ok( $vcard, 'vCard is present' ); 17 | 18 | my ($photo) = $vcard->get('photo'); 19 | ok( $photo, 'Photo is present' ); 20 | 21 | my $base64_image 22 | = 'R0lGODlhlgAyALMPAAAAAP9BAP////9PAP//AP/xAP/ZAP//Vv//sP+KAP+gAP9tAP9fAP+wAP/L 23 | AP///yH5BAEAAA8ALAAAAACWADIAQAT/8MlJq7046827/2DIAYIAVGRpAiyaqvApvXAtP2xc3hO9 24 | W6QWhcbD1VRF49GEARCe0JPzmZxSgVZC8pLVoqDenlPY3fbA2myxnGFvAIp4nCXfwuWKNd4MxOdR 25 | e4B/OH58Yn6DgnVthR0AA5CRkXaSA2uSVUI9lZeTKJAyj5iOoqBcnG2ojgGsrQF8AK6sPLGyLLNN 26 | ta9YraG6u7eytlW2vL1mwbOGIszNzs/Q0SFBM0s2LjY3PkuaYtfYPx85TFg+duNITQjrCLTrVezt 27 | XPHtUvViLADx8Oy+9zP05GHZB7AfEHqwEGpgYaBhQ4YPuTiMOGTish4TDayxiIIigIzL/z5mdFgF 28 | ZBuTbxaoVAlg5QI7Ll+icHlxRsw1NGfKxHHTQ8uV3WzmbNJzlbBdXIoNcUUrFrFjKJguxTWD6cVf 29 | SKP2WijVJ9ZXmr4O8yUsKBCqZ4+CFaM2q1a3PY7akRstX7l8ZvHlvRvSbq6aLq76XTh4GrUZ25A0 30 | 5RbK2jfEMc49HhEDhbUql9sUxhFkTWUu2dJV4wY6XYrFkYEo7vGZdbbSqZscmD3bV20gtA/Yyb13 31 | CADeuGtruz0jN/HgtKUA920c2e/lTQpIny5FulkA0wtUyQ4YO3cU34dYn5FdO+Hy3seLD88F/QgH 32 | 8OGziG8nvnwU9rvbd7AmP37+M+x31f9+/NXnXxMCjpDAgguywKAdDDaIQoTdRZjAGhROeOEMFtYE 33 | gIUbavggMh16yMCJDACAYopcrMjiECt25+IaMaJwYigz+lQjEDk20eMIlXhyyihDECmGJZ8YOYOS 34 | pYSiyhtPFqlkkkKOIBcyw0ylDGJwVbXVW1klo80veG2Gg1LSTKNWUPmUZVcyaCaFlpZgKSVWWWnN 35 | 6WWcceHp1Za5ZMlFML35BouY5+hi5lK9IaoZVGlGKumklFbKmi/5HGEmOt2Uiddqg54mWaGgNTqO 36 | qaI2cxg6mQ1B2miOheONYpiB6oitkGmKxavTyMoZY5a1ymqrsOJarK+I1YpsYuS4yiv/CKcFi6xr 37 | xDJbJrUrdCataM522tqxOygb264rdKsat75lE+1orGay2rrg2hEbEeCgm+63B/WjzTv58tuvv4vi 38 | QBAKAwsskMEFE6wvwgf3oJA6CSMnHA7JSbxbxSM05wLGxenWQ3PO8cYCdB0nhwzIC6HhhRVVgNFy 39 | FB6isYbLX4ThRhMyq1FzFG3I/EZ52rGgHnjUrcHez0fjkLR3obi3ENBFE01dG04vBJJIGknEUUUk 40 | +YQSRl1zHcrXuYykUUlbax32Qg203TYLbtvh9tsozN3d3A2sYXfdec+A91V45y333k38PUIhdyQy 41 | RCOLL+II4z0E0ngokC+ESCaV+5Y5/xcdZghEhyKGqKDnPZDOYYgfmq4Z6KGL/rnqudA0lE5A0b7T 42 | CEX1MLtQoeSeUu1A+G777W/EuKONx8+Q/EI/Ko8ijS+quHwb0+PQPPLP+xQkKJRMWQqSn3RS5ZLj 43 | s2AKDlGmMiX541N5vpV0yflln3o6tQafZGpJ1vxcdQVmo1bxyZqagD//nek6BtyTWxRFPz3Jz4Gc 44 | wQthJChAPz1wTljBy1ry1KX8KRBTbekgn5IVMBKSik6Q4iAG2wJACCqqTVC5UwrpxKavnMOCb2Ah 45 | PkKIlDsZglCDCuH+1oRAQKHQhfEzijLWAKdjMHGEvHCOm+43RQJu0AWCwmIAxVFCExiSioJpupZm 46 | upisN4DxLye0lBrXyEYPRAAAOw==' . "\x0A"; 47 | my $base64_image_decoded = MIME::Base64::decode($base64_image); 48 | is $photo->value, $base64_image_decoded, 'compare decoded values'; 49 | 50 | my $photo_value = MIME::Base64::encode( $photo->value ); 51 | is $photo_value, $base64_image, 'compare encoded values'; 52 | 53 | # $vcard->as_string returns a decoded string. 54 | # slurp_utf8() returns a decoded string 55 | my $original_vcard = path('t/base64.vcf')->slurp_utf8; 56 | is $vcard->as_string, $original_vcard, 57 | 'as_string() output is the same as the input'; 58 | 59 | # Uncomment these lines to view the gif and inspect the new and original images 60 | # visually. 61 | #path('/tmp/victoly_original.gif')->spew($base64_image_decoded); 62 | #path('/tmp/victoly_new.gif')->spew( $photo->value ); 63 | 64 | done_testing; 65 | -------------------------------------------------------------------------------- /t/vcard/address_book.t: -------------------------------------------------------------------------------- 1 | use Test::Most; 2 | 3 | use Path::Tiny qw/path tempfile/; 4 | use vCard::AddressBook; 5 | use Encode; 6 | 7 | my $in_file = path('t/complete.vcf'); 8 | my $out_file = tempfile('.vcard.out.vcfXXXX'); 9 | ##my $out_file = path('.vcard.out.vcf'); 10 | my $address_book = vCard::AddressBook->new; 11 | 12 | subtest 'load an address book' => sub { 13 | note 'add_vcard()'; 14 | $address_book->add_vcard; 15 | $address_book->add_vcard; 16 | $address_book->add_vcard; 17 | 18 | note 'load_file()'; 19 | $address_book->load_file($in_file); 20 | my $vcard = $address_book->vcards->[3]; 21 | 22 | note "simple getters and setters"; 23 | is $vcard->full_name, 'Bruce Banner, PhD', 'full_name()'; 24 | is $vcard->title, 'Research Scientist', 'title()'; 25 | is $vcard->photo, 'http://shh.supersecret.army.mil/bbanner.gif', 26 | 'photo()'; 27 | is ref $vcard->photo, 'URI::http', 'photo() returns a URI::http obj'; 28 | is $vcard->birthday, '19700414', 'birthday()'; 29 | is $vcard->timezone, 'UTC-7', 'timezone()'; 30 | 31 | note "complex getters and setters"; 32 | is_deeply $vcard->family_names, ['Banner'], 'family_names()'; 33 | is_deeply $vcard->given_names, ['Bruce'], 'given_names()'; 34 | is_deeply $vcard->other_names, [], 'other_names()'; 35 | is_deeply $vcard->honorific_prefixes, ['Dr.'], 'prefixes'; 36 | is_deeply $vcard->honorific_suffixes, ['PhD'], 'suffixes'; 37 | is_deeply $vcard->phones, expected_phones(), 'phones()'; 38 | is_deeply $vcard->addresses, expected_addresses(), 'addresses()'; 39 | is_deeply $vcard->email_addresses, expected_email_addresses(), 40 | 'email_addresses()'; 41 | }; 42 | 43 | subtest 'output address book' => sub { 44 | my $in_file_string = $in_file->slurp_utf8; 45 | 46 | $address_book->load_string($in_file_string); 47 | $address_book->as_file($out_file); 48 | 49 | my $contents = $out_file->slurp_utf8; 50 | 51 | is $contents, expected_out_file(), 'as_file()'; 52 | 53 | is scalar @{ $address_book->vcards }, 5, 'created the right # of vcards'; 54 | is ref $_, 'vCard', 'object reference' for @{ $address_book->vcards }; 55 | }; 56 | 57 | done_testing; 58 | 59 | sub expected_phones { 60 | [ { type => ['work'], number => '651-290-1234', preferred => 1 }, 61 | { type => [ 'cell', 'text' ], 62 | number => '651-290-1111', 63 | preferred => 0 64 | } 65 | ]; 66 | } 67 | 68 | sub expected_addresses { 69 | [ { type => ['home'], 70 | preferred => 0, 71 | po_box => undef, 72 | street => 'Main St', 73 | city => 'Desert Base', 74 | region => 'New Mexico', 75 | post_code => '55416', 76 | country => 'USA', 77 | extended => undef, 78 | }, 79 | { type => ['work'], 80 | preferred => 0, 81 | po_box => undef, 82 | street => Encode::decode( 'UTF-8', '部队街' ), 83 | city => 'Desert Base', 84 | region => 'New Mexico', 85 | post_code => '55416', 86 | country => 'USA', 87 | extended => undef, 88 | }, 89 | ]; 90 | } 91 | 92 | sub expected_email_addresses { 93 | [ { type => ['work'], 94 | address => 'bbanner.work@example.com', 95 | preferred => 1 96 | }, 97 | { type => ['home'], 98 | address => 'bbanner.home@example.com', 99 | preferred => 0 100 | } 101 | ]; 102 | } 103 | 104 | sub expected_out_file { 105 | my $in_file_string = $in_file->slurp_utf8; 106 | return 107 | "BEGIN:VCARD\x0D\x0AVERSION:4.0\x0D\x0AEND:VCARD\x0D\x0A" x 3 108 | . $in_file_string 109 | . $in_file_string; 110 | } 111 | 112 | -------------------------------------------------------------------------------- /t/02-vcard.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | 5 | use lib qw(./lib); 6 | 7 | use Test::More tests => 32; 8 | use Data::Dumper; 9 | 10 | # Check we can load module 11 | BEGIN { use_ok('Text::vCard'); } 12 | BEGIN { use_ok('Text::vCard::Addressbook'); } 13 | 14 | local $SIG{__WARN__} = sub { die $_[0] }; 15 | 16 | ####### 17 | # Test new() 18 | ####### 19 | 20 | my $function 21 | = Text::vCard::new( 'foo::bar', { 'source_file' => 't/simple.vcf' } ); 22 | is( ref($function), 'foo::bar', 'Can use as a base class' ); 23 | 24 | my $hash = Text::vCard::new( { foo => 'bar' }, 25 | { 'source_file' => 't/simple.vcf' } ); 26 | is( ref($hash), 'HASH', 'new() retruns HASH when supplied hash' ); 27 | 28 | eval { Text::vCard::new(undef); }; 29 | like( $@, qr/Use of uninitialized value/, 'Errors if no class supplied' ); 30 | $@ = 'foo'; 31 | 32 | my $adbk 33 | = Text::vCard::Addressbook->new( { 'source_file' => 't/simple.vcf' } ); 34 | my $vcard = $adbk->vcards()->[0]; 35 | 36 | ####### 37 | # Test add_node() 38 | ####### 39 | eval { $vcard->add_node(); }; 40 | like( 41 | $@, 42 | qr/Must supply a node_type/, 43 | 'Croak if add_node() not supplied with anything' 44 | ); 45 | 46 | eval { $vcard->add_node( {} ); }; 47 | like( 48 | $@, 49 | qr/Must supply a node_type/, 50 | 'Croak if add_node() not supplied with node_type' 51 | ); 52 | 53 | my %data = ( 54 | 'params' => [ { 'type' => 'HOME,PREF', }, ], 55 | 'value' => 56 | ';;First work address - street;Work city;London;Work PostCode;CountryName', 57 | ); 58 | my @d = ( \%data ); 59 | 60 | my $new_address = $vcard->add_node( 61 | { 'node_type' => 'ADR', 62 | 'data' => \@d, 63 | } 64 | ); 65 | isa_ok( $new_address, 'Text::vCard::Node' ); 66 | 67 | ###### 68 | # get_simple_type 69 | ###### 70 | 71 | is( $vcard->get_simple_type( 'tel', 'home' ), '020 666 6666' ); 72 | 73 | ####### 74 | # Test get_of_type() 75 | ####### 76 | 77 | my $home_adds_pref = $vcard->get_of_type( 'addresses', [ 'home', 'pref' ] ); 78 | 79 | is( scalar( @{$home_adds_pref} ), 80 | 2, 'get_of_type() types returns 2 not 3 addresses with array ref' ); 81 | 82 | is( $vcard->get_of_type('foo'), 83 | undef, 'nothing of this type found, undef returned' ); 84 | 85 | my $home_adds = $vcard->get_of_type( 'addresses', 'home' ); 86 | 87 | is( scalar( @{$home_adds} ), 88 | 3, 'get_of_type() types returns 3 not 3 addresses with scalar' ); 89 | 90 | is( $vcard->get_of_type( 'addresses', 'foo' ), 91 | undef, 'Undef returned when no addresses available' ); 92 | 93 | is( ref($home_adds), 'ARRAY', 'Returns array ref when called in context' ); 94 | 95 | my @list = $vcard->get_of_type( 'addresses', 'pref' ); 96 | is( scalar(@list), 2, 'Got all 2 addresses from array' ); 97 | 98 | my @list_all = $vcard->get_of_type('addresses'); 99 | is( scalar(@list_all), 3, 'Got 3 addresses from array as expected' ); 100 | 101 | ####### 102 | # Test get() 103 | ####### 104 | 105 | eval { $vcard->get(); }; 106 | like( 107 | $@, 108 | qr/You did not supply an element type/, 109 | 'get() croaks is no params supplied' 110 | ); 111 | 112 | my $addresses = $vcard->get( { 'node_type' => 'addresses' } ); 113 | my $also_addresses = $vcard->get('addresses'); 114 | 115 | ok( eq_array( $addresses, $also_addresses ), 116 | 'get() with single element and node_type match' 117 | ); 118 | 119 | my $home_adds_get = $vcard->get( 120 | { 'node_type' => 'addresses', 121 | 'types' => [ 'home', 'pref' ], 122 | } 123 | ); 124 | 125 | is( scalar( @{$home_adds_get} ), 2, 'get() types returns 2 not 3 addresses' ); 126 | 127 | ##### 128 | # test the auto generated methods 129 | ##### 130 | 131 | is( $vcard->FN(), 'T-firstname T-surname', 'autogen methods - got FN' ); 132 | is( $vcard->fullname('new name'), 133 | 'new name', 'autogen methods - updated fullname' ); 134 | is( $vcard->fn(), 'new name', 'autogen methods - got new fn' ); 135 | 136 | # try adding a new one 137 | is( $vcard->email(), undef, 138 | 'autogen methods - undef for no email as expected' ); 139 | is( $vcard->email('n.e@body.com'), 140 | 'n.e@body.com', 'autogen methods - new value set' ); 141 | 142 | is( $vcard->nickname('T-Nickname'), 143 | 'T-Nickname', 'autogen methods - new value set' ); 144 | is( $vcard->birthday('new bd'), 'new bd', 'autogen added with alias' ); 145 | 146 | ###### 147 | # 148 | ###### 149 | 150 | my $names = $vcard->get( { 'node_type' => 'name' } ); 151 | is( $names->[0]->family(), 152 | 'T-surname', 'got name - but this will be depreciated' ); 153 | 154 | my $names2 = $vcard->get( { 'node_type' => 'moniker' } ); 155 | is( $names2->[0]->family(), 'T-surname', 'got moniker' ); 156 | 157 | ###### 158 | # get get_group() 159 | ###### 160 | my $adgroup = Text::vCard::Addressbook->new( 161 | { 'source_file' => 't/apple_version3.vcf' } ); 162 | 163 | my $adgr_vcards = $adgroup->vcards(); 164 | 165 | my $adgr_vcard = $adgr_vcards->[0]; 166 | 167 | my $item1_nodes = $adgr_vcard->get_group('item1'); 168 | is( scalar( @{$item1_nodes} ), 169 | 2, 'get_group("item1") - got 2 nodes as arrayref - expected' ); 170 | 171 | my @item1_nodes_array = $adgr_vcard->get_group('item1'); 172 | is( scalar(@item1_nodes_array), 173 | 2, 'get_group("item1") - got 2 nodes as array - expected' ); 174 | 175 | my $item2_abadr = $adgr_vcard->get_group( 'item2', 'X-AbADR' ); 176 | is( $item2_abadr->[0]->value(), 177 | 'uk', 'get_group("item2","X-AbADR") - got value from node' ); 178 | 179 | eval { $adgr_vcard->get_group(); }; 180 | 181 | like( 182 | $@, 183 | qr/No group name supplied/, 184 | 'get_group - carp if no group name supplied' 185 | ); 186 | 187 | -------------------------------------------------------------------------------- /t/vcard.t: -------------------------------------------------------------------------------- 1 | use Test::Most; 2 | 3 | use Encode; 4 | use Path::Tiny qw/tempfile path/; 5 | use vCard; 6 | 7 | my $tmp_file = tempfile('.simple.vcfXXXX'); 8 | my $hashref = hashref(); 9 | my $vcard = vCard->new->load_hashref($hashref); 10 | 11 | subtest 'output methods' => sub { 12 | is $vcard->as_string, expected_vcard(), "as_string()"; 13 | is $vcard->as_file($tmp_file)->stringify, "$tmp_file", "as_file()"; 14 | 15 | my $tmp_contents = $tmp_file->slurp_utf8; 16 | is $tmp_contents, expected_vcard(), "file contents ok"; 17 | }; 18 | 19 | subtest 'simple getters' => sub { 20 | foreach my $node_type ( vCard->_simple_node_types ) { 21 | is $vcard->$node_type, $hashref->{$node_type}, $node_type; 22 | } 23 | }; 24 | 25 | subtest 'photo' => sub { 26 | $vcard->photo( $hashref->{photo} ); 27 | is ref( $vcard->photo ), 'URI::http', 'returns a URI::http object'; 28 | 29 | $vcard->photo( URI->new( $hashref->{photo} ) ); 30 | is ref( $vcard->photo ), 'URI::http', 'returns a URI::http object'; 31 | 32 | is $vcard->photo, $hashref->{photo}, 'photo'; 33 | }; 34 | 35 | subtest 'complex getters' => sub { 36 | is_deeply $vcard->family_names, ['Banner'], 'family_names()'; 37 | is_deeply $vcard->given_names, ['Bruce'], 'given_names()'; 38 | is_deeply $vcard->honorific_prefixes, ['Dr.'], 'prefixes'; 39 | is_deeply $vcard->honorific_suffixes, ['PhD'], 'suffixes'; 40 | 41 | my $phones = $vcard->phones; 42 | is_deeply $phones->[0]->{type}, ['work'], 'work phone'; 43 | is_deeply $phones->[1]->{type}, ['cell'], 'cell phone'; 44 | 45 | my $addresses = $vcard->addresses; 46 | is $addresses->[0]->{city}, 'Desert Base', 'work address'; 47 | is $addresses->[1]->{city}, 'Desert Base', 'home address'; 48 | 49 | my $emails = $vcard->email_addresses; 50 | is_deeply $emails->[0]->{type}, ['work'], 'work email address'; 51 | is_deeply $emails->[1]->{type}, ['home'], 'home email address'; 52 | }; 53 | 54 | subtest 'load_file() with chaining' => sub { 55 | my $vcard2 = vCard->new->load_file($tmp_file); 56 | test_simple_node_types($vcard2); 57 | }; 58 | 59 | subtest 'load_file() w/o chaining' => sub { 60 | my $vcard2 = vCard->new; 61 | $vcard2->load_file($tmp_file); 62 | test_simple_node_types($vcard2); 63 | }; 64 | 65 | subtest 'load_string() with chaining' => sub { 66 | my $tmp_contents = $tmp_file->slurp_utf8; 67 | my $vcard3 = vCard->new->load_string($tmp_contents); 68 | test_simple_node_types($vcard3); 69 | }; 70 | 71 | subtest 'load_string() w/o chaining' => sub { 72 | my $tmp_contents = $tmp_file->slurp_utf8; 73 | my $vcard3 = vCard->new; 74 | $vcard3->load_string($tmp_contents); 75 | test_simple_node_types($vcard3); 76 | }; 77 | 78 | # \r\n must be used as line endings. This is required by the RFC. 79 | subtest 'load_string() w/no carriage returns' => sub { 80 | my $string = raw_vcard(); 81 | $string =~ s/\r//g; 82 | throws_ok { vCard->new->load_string($string) } qr/ERROR/, 83 | 'caught exception for a string with no carriage returns'; 84 | }; 85 | 86 | done_testing; 87 | 88 | sub test_simple_node_types { 89 | my ($vcard) = @_; 90 | 91 | is ref $vcard, 'vCard', 'object type is good'; 92 | 93 | foreach my $node_type ( vCard->_simple_node_types ) { 94 | next if $node_type eq 'full_name'; 95 | is $vcard->$node_type, $hashref->{$node_type}, $node_type; 96 | } 97 | } 98 | 99 | # everything below this line is test data 100 | 101 | sub raw_vcard { 102 | return < 'Bruce Banner, PhD', 127 | given_names => ['Bruce'], 128 | family_names => ['Banner'], 129 | honorific_prefixes => ['Dr.'], 130 | honorific_suffixes => ['PhD'], 131 | title => 'Research Scientist', 132 | photo => 'http://shh.supersecret.army.mil/bbanner.gif', 133 | birthday => '19700414', 134 | timezone => 'UTC-7', 135 | phones => [ 136 | { type => ['work'], 137 | number => '651-290-1234', 138 | preferred => 1, 139 | }, 140 | { type => ['cell'], 141 | number => '651-290-1111' 142 | }, 143 | ], 144 | addresses => [ 145 | { type => ['work'], 146 | street => decode( 'utf8', '部队街' ), 147 | city => 'Desert Base', 148 | region => 'New Mexico', 149 | post_code => '55416', 150 | country => 'USA', 151 | }, 152 | { type => ['home'], 153 | street => 'Main St', 154 | city => 'Desert Base', 155 | region => 'New Mexico', 156 | post_code => '55416', 157 | country => 'USA', 158 | }, 159 | ], 160 | email_addresses => [ 161 | { type => ['work'], 162 | address => 'bbanner.work@example.com', 163 | preferred => 1 164 | }, 165 | { type => ['home'], 166 | address => 'bbanner.home@example.com', 167 | }, 168 | ], 169 | }; 170 | } 171 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | vCard - Read, write, and edit vCards 4 | 5 | # SYNOPSIS 6 | 7 | use vCard; 8 | 9 | # create the object 10 | my $vcard = vCard->new; 11 | 12 | # these methods load vCard data 13 | # (see method documentation for details) 14 | $vcard->load_file($filename); 15 | $vcard->load_string($string); 16 | $vcard->load_hashref($hashref); 17 | 18 | # simple getters/setters 19 | $vcard->full_name('Bruce Banner, PhD'); 20 | $vcard->title('Research Scientist'); 21 | $vcard->photo('http://example.com/bbanner.gif'); 22 | 23 | # complex getters/setters 24 | $vcard->phones([ 25 | { type => ['work', 'text'], number => '651-290-1234', preferred => 1 }, 26 | { type => ['home'], number => '651-290-1111' } 27 | ]); 28 | $vcard->email_addresses([ 29 | { type => ['work'], address => 'bbanner@ssh.secret.army.mil' }, 30 | { type => ['home'], address => 'bbanner@timewarner.com' }, 31 | ]); 32 | 33 | # these methods output data in vCard format 34 | my $file = $vcard->as_file($filename); # writes to $filename 35 | my $string = $vcard->as_string; # returns a string 36 | 37 | # DESCRIPTION 38 | 39 | A vCard is a digital business card. vCard and [vCard::AddressBook](https://metacpan.org/pod/vCard::AddressBook) provide an 40 | API for parsing, editing, and creating vCards. 41 | 42 | This module is built on top of [Text::vCard](https://metacpan.org/pod/Text::vCard). It provides a more intuitive user 43 | interface. 44 | 45 | To handle an address book with several vCard entries in it, start with 46 | [vCard::AddressBook](https://metacpan.org/pod/vCard::AddressBook) and then come back to this module. 47 | 48 | Note that the vCard RFC requires version() and full_name(). This module does 49 | not check or warn if these conditions have not been met. 50 | 51 | # ENCODING AND UTF-8 52 | 53 | See the 'ENCODING AND UTF-8' section of [vCard::AddressBook](https://metacpan.org/pod/vCard::AddressBook). 54 | 55 | # METHODS 56 | 57 | ## load_hashref(\$hashref) 58 | 59 | \$hashref should look like this: 60 | 61 | full_name => 'Bruce Banner, PhD', 62 | given_names => ['Bruce'], 63 | family_names => ['Banner'], 64 | title => 'Research Scientist', 65 | photo => 'http://example.com/bbanner.gif', 66 | phones => [ 67 | { type => ['work'], number => '651-290-1234', preferred => 1 }, 68 | { type => ['cell'], number => '651-290-1111' }, 69 | }, 70 | addresses => [ 71 | { type => ['work'], ... }, 72 | { type => ['home'], ... }, 73 | ], 74 | email_addresses => [ 75 | { type => ['work'], address => 'bbanner@shh.secret.army.mil' }, 76 | { type => ['home'], address => 'bbanner@timewarner.com' }, 77 | ], 78 | 79 | Returns \$self in case you feel like chaining. 80 | 81 | ## load_file(\$filename) 82 | 83 | Returns \$self in case you feel like chaining. 84 | 85 | ## load_string(\$string) 86 | 87 | Returns $self in case you feel like chaining. This method assumes $string is 88 | decoded (but not MIME decoded). 89 | 90 | ## as_string() 91 | 92 | Returns the vCard as a string. 93 | 94 | ## as_file(\$filename) 95 | 96 | Write data in vCard format to \$filename. 97 | 98 | Dies if not successful. 99 | 100 | # SIMPLE GETTERS/SETTERS 101 | 102 | These methods accept and return strings. 103 | 104 | ## version() 105 | 106 | Version number of the vcard. Defaults to '4.0' 107 | 108 | ## full_name() 109 | 110 | A person's entire name as they would like to see it displayed. 111 | 112 | ## title() 113 | 114 | A person's position or job. 115 | 116 | ## nickname() 117 | 118 | A person's nickname. 119 | 120 | ## photo() 121 | 122 | This should be a link. Accepts a string or a URI object. This method 123 | always returns a [URI](https://metacpan.org/pod/URI) object. 124 | 125 | TODO: handle binary images using the data uri schema 126 | 127 | ## birthday() 128 | 129 | ## timezone() 130 | 131 | # COMPLEX GETTERS/SETTERS 132 | 133 | These methods accept and return array references rather than simple strings. 134 | 135 | ## family_names() 136 | 137 | Accepts/returns an arrayref of family names (aka surnames). 138 | 139 | ## given_names() 140 | 141 | Accepts/returns an arrayref. 142 | 143 | ## other_names() 144 | 145 | Accepts/returns an arrayref of names which don't qualify as family_names or 146 | given_names. 147 | 148 | ## honorific_prefixes() 149 | 150 | Accepts/returns an arrayref. eg `[ 'Dr.' ]` 151 | 152 | ## honorific_suffixes() 153 | 154 | Accepts/returns an arrayref. eg `[ 'Jr.', 'MD' ]` 155 | 156 | ## phones() 157 | 158 | Accepts/returns an arrayref that looks like: 159 | 160 | [ 161 | { type => ['work'], number => '651-290-1234', preferred => 1 }, 162 | { type => ['cell'], number => '651-290-1111' }, 163 | ] 164 | 165 | ## addresses() 166 | 167 | Accepts/returns an arrayref that looks like: 168 | 169 | [ 170 | { type => ['work'], street => 'Main St', preferred => 0 }, 171 | { type => ['home'], 172 | pobox => 1234, 173 | extended => 'asdf', 174 | street => 'Army St', 175 | city => 'Desert Base', 176 | region => '', 177 | post_code => '', 178 | country => 'USA', 179 | preferred => 1, 180 | label => '1234\nasdf\nArmy St\nDesert Base\nUSA', 181 | }, 182 | ] 183 | 184 | ## email_addresses() 185 | 186 | Accepts/returns an arrayref that looks like: 187 | 188 | [ 189 | { type => ['work'], address => 'bbanner@ssh.secret.army.mil' }, 190 | { type => ['home'], address => 'bbanner@timewarner.com', preferred => 1 }, 191 | ] 192 | 193 | # AUTHOR 194 | 195 | Eric Johnson (kablamo), github ~!at!~ iijo dot org 196 | 197 | # ACKNOWLEDGEMENTS 198 | 199 | Thanks to [Foxtons](http://foxtons.co.uk) for making this module possible by 200 | donating a significant amount of developer time. 201 | -------------------------------------------------------------------------------- /t/01-node.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | 5 | use lib qw(./lib); 6 | 7 | use Test::More tests => 41; 8 | use Data::Dumper; 9 | 10 | # Check we can load module 11 | BEGIN { use_ok('Text::vCard::Node'); } 12 | 13 | local $SIG{__WARN__} = sub { die $_[0] }; 14 | 15 | ##### 16 | # Set up some test data 17 | ##### 18 | 19 | # ok data 20 | my %data = ( 21 | 'params' => [ { 'type' => 'HOME,PREF', }, ], 22 | 'value' => 23 | ';;First work address - street;Work city;London;Work PostCode;CountryName', 24 | ); 25 | 26 | # Address fields 27 | my $fields = [ 28 | 'po_box', 'extended', 'street', 'city', 29 | 'region', 'post_code', 'country' 30 | ]; 31 | 32 | ##### 33 | # Test new() 34 | ##### 35 | 36 | my $foo = Text::vCard::Node::new( 'foo::bar', { fields => ['value'] } ); 37 | 38 | is( ref($foo), 'foo::bar', 'Can use as a base class' ); 39 | 40 | my $hash 41 | = Text::vCard::Node::new( { foo => 'bar' }, { 'fields' => ['value'] } ); 42 | is( ref($hash), 'HASH', 'new() retruns HASH when supplied hash' ); 43 | 44 | eval { Text::vCard::Node::new( undef, { 'fields' => ['value'] } ); }; 45 | like( $@, qr/Use of uninitialized value/, 'Errors if no class supplied' ); 46 | $@ = 'foo'; 47 | 48 | eval { Text::vCard::Node->new( {} ); }; 49 | like( $@, qr/No fields defined/, 'new() carps when no fields supplied' ); 50 | 51 | eval { Text::vCard::Node->new( { 'fields' => { 'duff' => 'hash' } } ); }; 52 | like( 53 | $@, 54 | qr/fields is not an array ref/, 55 | 'new() carps when fields is not an array ref' 56 | ); 57 | 58 | my %too_many_value_data 59 | = ( 'value' => 60 | 'asd;Street;Work city;London;Work PostCode;CountryName;more;values', 61 | ); 62 | eval { 63 | my $duff = Text::vCard::Node->new( 64 | { fields => $fields, 65 | data => \%too_many_value_data, 66 | } 67 | ); 68 | }; 69 | like( 70 | $@, 71 | qr/Data value had 8 elements expecting 7 or less/, 72 | 'new() carp on wrong number of elements in value comp to fields' 73 | ); 74 | 75 | my %a_few_data_points = ( 'value' => 'x;s;Street;City', ); 76 | 77 | # Working nodes 78 | my $nod_few_fields = Text::vCard::Node->new( 79 | { fields => $fields, 80 | data => \%a_few_data_points, 81 | } 82 | ); 83 | is( $nod_few_fields->street(), 84 | 'Street', 'new() - less data than fields, field set ok' ); 85 | is( $nod_few_fields->post_code(), 86 | undef, 'new() - less data, empty field returns undef' ); 87 | $nod_few_fields->post_code('postcode'); 88 | is( $nod_few_fields->post_code(), 89 | 'postcode', 'new() - less data, set empty field' ); 90 | 91 | # Create without a node_type - should be fine 92 | my $no = Text::vCard::Node->new( 93 | { fields => $fields, 94 | data => \%data, 95 | } 96 | ); 97 | 98 | # Create without a data - should be fine 99 | my $no_data = Text::vCard::Node->new( { fields => $fields, } ); 100 | is( $no_data->street(), undef, 101 | 'Created node with no data and methods created' ); 102 | 103 | # Create 'working' node 104 | my $node = Text::vCard::Node->new( 105 | { node_type => 'address', # Auto upper cased 106 | fields => $fields, 107 | data => \%data, 108 | group => 'item1', 109 | } 110 | ); 111 | 112 | is( $no->street(), $node->street(), 113 | 'new() without node_type still works ok' ); 114 | is( $node->group(), 'item1', 'got group as it was set' ); 115 | is( $node->group('FooF'), 'foof', 'set node worked' ); 116 | ### 117 | # ORG 118 | ### 119 | my %orgdata = ( 'value' => 'name;unit;extra', ); 120 | my $org = Text::vCard::Node->new( 121 | { node_type => 'ORG', 122 | fields => [ 'name', 'unit' ], 123 | data => \%orgdata, 124 | } 125 | ); 126 | is( scalar( @{ $org->unit() } ), 2, 'org - Got two elements back from unit' ); 127 | my @new_org = qw(a b c); 128 | is( scalar( @{ $org->unit( \@new_org ) } ), 129 | 3, 'org - Got the elements back from setting unit' ); 130 | 131 | is( scalar( @{ $org->unit('foo') } ), 132 | 3, 'org - Got the elements back from trying to set unit with string' ); 133 | 134 | my %single_org = ( 'value' => 'just_name', ); 135 | my $org_name = Text::vCard::Node->new( 136 | { node_type => 'ORG', 137 | fields => [ 'name', 'unit' ], 138 | data => \%single_org, 139 | } 140 | ); 141 | is( $org_name->unit(), undef, 'org - copes with unit being empty' ); 142 | 143 | ##### 144 | # types() 145 | ##### 146 | my $types = $node->types(); 147 | my @types = $node->types(); 148 | ok( scalar(@types), 'types() returns stuff' ); 149 | ok( eq_array( $types, \@types ), 'types() ok in array or scalar context' ); 150 | is( $no_data->types(), undef, 'types() get undef when there are none' ); 151 | 152 | ##### 153 | # is_type() 154 | ##### 155 | ok( $node->is_type('home'), 'is_type() home type matches' ); 156 | ok( !$node->is_type('work'), 'is_type() not work address type' ); 157 | is( $no_data->is_type('work'), undef, 'is_type() undef when no params' ); 158 | 159 | ##### 160 | # is_pref() 161 | ##### 162 | ok( $node->is_pref(), 'is_pref() this is a prefered address' ); 163 | $node->remove_types('pref'); 164 | is( $node->is_pref(), undef, 'is_pref() get undef when not pref' ); 165 | is( $no_data->is_pref(), undef, 'is_pref() get undef if no params' ); 166 | 167 | ##### 168 | # remove_types() 169 | ##### 170 | is( $no_data->remove_types('wibble'), 171 | undef, 'remove_types() when no params - no error' ); 172 | is( $node->remove_types('wibble'), 173 | undef, 'remove_types() undef when scalar, node has params and no match' ); 174 | is( $node->remove_types( ['home'] ), 175 | 1, 'remove_types() get a true value in array context when sucess' ); 176 | 177 | ##### 178 | # add_types() 179 | ##### 180 | # Test the types 181 | $node->add_types('WoRk'); 182 | ok( $node->is_type('wOrk'), 183 | 'is_type() Added work type and check non-cases sensative' ); 184 | $node->remove_types( [ 'Work', 'Home' ] ); 185 | ok( !$node->is_type('Work'), 186 | 'is_type() Removed work type and check non-cases sensative' ); 187 | ok( !$node->is_type('home'), 'is_type() Removed several types' ); 188 | $node->add_types( [ 'work', 'home' ] ); 189 | ok( $node->is_type('work') && $node->is_type('home'), 190 | 'is_type() Added two types ok' ); 191 | $no_data->add_types('work'); 192 | ok( $no_data->is_type('work'), 193 | 'is_type() Added type to node with no params' ); 194 | 195 | ##### 196 | # AUTOLOAD 197 | ##### 198 | 199 | is( $node->po_box(), '', 'AUTOLOAD - Po box empty as expected' ); 200 | is( $node->street(), 201 | 'First work address - street', 202 | 'AUTOLOAD - Street address matches' 203 | ); 204 | is( $node->country('Moose vill'), 'Moose vill', 'AUTOLOAD - set ok' ); 205 | 206 | eval { $node->duff_method(); }; 207 | like( 208 | $@, 209 | qr/duff_method method which is not valid for this node/, 210 | 'AUTOLOAD - carp when method not valid' 211 | ); 212 | 213 | #### 214 | # export_data() 215 | #### 216 | my $export 217 | = ';;First work address - street;Work city;London;Work PostCode;Moose vill'; 218 | is( $node->export_data(), $export, 219 | 'export_data() - Node returns expected data' ); 220 | 221 | delete $node->{'po_box'}; 222 | is( $node->export_data(), $export, 223 | 'export_data() - Node returns expected data, with undef entry' ); 224 | 225 | # Test non-existant methods 226 | 227 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Text::vCard. 2 | 3 | 3.09 Sun 23 Oct 2016 20:24:06 BST 4 | - Support Orgs (worthmine) 5 | 6 | 3.08 Sun 9 Oct 2016 21:56:23 BST 7 | - Enconde/decode the key value pair to UTF-8 solves (jluis) 8 | 9 | 3.07 Thu 15 Jan 2015 21:44:21 GMT 10 | - POD fixes (kablamo) 11 | 12 | 3.06 Thu 12 Jun 2014 19:55:51 BST 13 | - Fixed Text::vCard::Node->add_types() (kablamo) 14 | - Fix/guess for tests failing on windows (kablamo) 15 | 16 | 3.05 Tue 13 May 2014 18:04:30 BST 17 | - Another win attempt to fix (kablamo) 18 | - Get travis working! (kablamo) 19 | 20 | 3.04 Tue 29 Apr 2014 20:21:52 21 | - Try a fix for Win32 (kablamo) 22 | 23 | 3.03 Fri 25 Apr 2014 19:23:43 24 | - Better error msg for vcards w/o proper line endings (kablamo) 25 | - Bug fix for names. +test (kablamo) 26 | 27 | 3.02 Fri 14 Feb 18:35:55 2014 28 | - Try fix Win32, switch File::Slurp to Path::Tiny (kablamo) 29 | 30 | 3.01 Mon 10 Feb 11:52:00 2014 31 | - Try fix Win32 (kablamo) 32 | 33 | 3.0 Tue Jan 21 15:25:40 GMT 2014 34 | - Major changes! 35 | - Initial release of vCard and vCard::AddressBook 36 | - Fix line unwrapping when reading vcards 37 | - Rewrote Text::vCard::Node->as_string() 38 | - Rewrote Text::vCard::AddressBook->export() 39 | - Redo the way that encoding and decoding works 40 | - Correctly wrap utf8 encoded strings 41 | - Fix encoding issues with MIME::Base64 and MIME::QuotedPrint 42 | - Do a better job escaping and unescaping '\', ';', and ',' 43 | - Fix for writing vcards with ORG values 44 | - Fix to remove extra semi colon when writing vcards 45 | - Version defaults to 4.0 when using the new vCard library 46 | 47 | 2.13 Thu 20 Dec 2012 19:34:44 GMT 48 | - Under the newer combined RFC6350 - every END:VCARD must 49 | be followed by \r\n (including last one)- reported by ysth 50 | - Fix for tests, should now work under Perl 5.17.6 - Ron Savage 51 | 52 | 2.12 Mon 10 Sep 2012 21:09:45 BST 53 | - perltidy everything 54 | - Adding base64 encode/decode (doriantaylor) 55 | 56 | 2.11 Thu 21 May 2012 08:48:46 BST 57 | - Merge POD cleanup and improvements (szabgab) 58 | 59 | 2.10 Tue 11 Jan 2011 21:50:02 GMT 60 | - Merged in quote-printed code (Christian Varga) 61 | - Cleaned up the tests and code for quote-printed 62 | 63 | 2.09 Thu 19 Aug 2010 16:08:20 BST 64 | - Add set_encoding() for export - Stefan 65 | 66 | 2.08 Tue Jul 13 08:47:58 BST 2010 67 | - Doc fix (Blair Christensen) 68 | 69 | 2.07 Wed 28 Jan 2010 22:16:05 GMT 70 | - Fix bug in get_simple_type() (Philip A. Prindeville) 71 | - Simplify Makefile.PL and deprecate unused fields (Philip A. Prindeville) 72 | 73 | 2.06 Sun 24 Jan 2010 10:02:01 GMT 74 | - Doc typos (Philip A. Prindeville) 75 | - Add get_simple_type() and import_data() (Philip A. Prindeville) 76 | - Doc typos (Philip A. Prindeville) 77 | 78 | 2.05 Fri 8 Jan 2010 22:28:50 GMT 79 | - Put back changes which were missed out 80 | 81 | 2.04 Fri 8 Jan 2010 22:00:20 GMT 82 | - Improvements to Makefile.PL and require 5.6 - thanks cpanservice 83 | - Switch to git repo 84 | - Doc patch 85 | 86 | 2.03 Sun Mar 16 10:10:54 GMT 2008 87 | - added 'moniker' and marked 'name' as depreciated 88 | 89 | 2.02 Sat Mar 15 17:15:16 GMT 2008 90 | - http://rt.cpan.org/Ticket/Display.html?id=34044 91 | Clean up tests so they pass in perl 5.10 92 | thanks to Neil Williams 93 | 94 | 2.01 Sun Sep 2 2007 95 | - Stop empty TYPE= being set on export when not needed 96 | thanks to Vadim for the suggestion 97 | 98 | 2.00 Sat Oct 21 2006 99 | - export now gives 'TYPE=x,y' instead of the incorrect 'x;y' 100 | 101 | 1.99 Wed 30th Aug 2006 102 | - Added 'quoted-printable' fix [rt.cpan.org #17790] 103 | this requires MIME::QuotedPrint 104 | 105 | 1.98 Mon Jul 17 2006 106 | - Test fix 107 | 108 | 1.97 Sun Jul 2 2006 109 | - removed test because I don't think Test::More::is_deaply 110 | works correctly on: perl 5.8.0 on Solaris x86 9 111 | 112 | 1.96 Sun 3rd July 2005 113 | - Removed String::ShellQuote - forgot to PREREQ and not using it 114 | 115 | 1.95 Sun 26th June 2005 116 | - Made export() work for address book, still missing encoding 117 | though. 118 | - Added basic test for export() 119 | - A few little clean up things 120 | 121 | 1.94 Sun 24th April 2005 122 | - Made check for 'VCARD' tag case insensative, 123 | probably won't help until Text::vFile::asData does as well. 124 | 125 | 1.93 Mon 31st Jan 2005 126 | - Restructured object so all nodes are stored in a hashref 127 | $self->{nodes} so I can get get_group to work, all other 128 | methods updated to reflect this. 129 | - added get_group() to vcard 130 | 131 | 1.92 132 | - Added group() to Node and extract that info 133 | from the vcard if it is there. 134 | 135 | 1.91 136 | - Doc bug, said 'tels', should have been 'tel'. 137 | 138 | 1.9 139 | - removed import() from docs as not used now 140 | - changed Node so excepts data with less than field order elements 141 | e.g. N, accepts 'Jon;Smith', As well as 'Jon;Smith;Dr;' this means 142 | we work better according to the RFC 143 | - ORGs' 'unit' method requires and returns an array ref as it is 144 | unlimited in the number of elements it has 145 | 146 | 1.8 Fri 15th Oct 2004 147 | - Applied patch from Aaron Cope for version stuff, can 148 | now access it as lowercase version(). 149 | 150 | 1.7 Wed 13th Oct 2004 151 | - remembered to update module versions as well as makefile! 152 | 153 | 1.6 Wed 13th Oct 2004 154 | - removed import() and made anonsub again 155 | - removed version() as was conflicting with $VERSION, 156 | info can be accessed through other methods in anycase 157 | 158 | 1.5 Wed Oct 6th 2004 159 | - Change to support asData change for 'type=home;type=pref' 160 | - Change to support escaped ; (\;) in data - 'note' now works 161 | 162 | 1.4 Tue Oct 5th 2004 163 | - Patches from Arron for XML::Generator::vCard 164 | - put auto methods in sub rather than closure for vCard.pm 165 | - change read_file() to scalar read_file() in address 166 | 167 | 1.3 Tue Oct 5th 2004 168 | - Added missing File::Slurp dependency 169 | - Renamed 'element_type' to 'node_type' as well 170 | - doc updates with help from binary 171 | 172 | 1.2 Sat Oct 2nd 2004 173 | - Changed so can parse group.NODE, the group is ignored for now 174 | - Added test for apple vcard version 3 175 | - emailed asData author about small buy with types (home/pref) 176 | - added autogen methods; $vcard->fn(), $vcard->fullname($value) 177 | 178 | 1.1 Wed Sept 15th 2003 179 | - Lots of tests added 180 | - Restructured (it's Tom's fault) so we use Addressbook as the main 181 | interface, and Text::vCard is a single card, in the Addressbook object 182 | - Renamed add_type to add_types 183 | - Renamed remove_type to remove_types 184 | - Created Text::vCard::Node to replace all Text::vCard::Part* 185 | - Dropped requirement for Text::vFile 186 | - Created new and load methods, dropped iterator 187 | - Renamed update_value to export_data and changed returned value 188 | 189 | 1.0 Wed July 23rd 11:18:00 2003 190 | - More doc fixing 191 | - Fixed bug in UID and TZ 192 | - test 02-evolution.t ready for Jay's 'type' fix to support v2.1 193 | - test 03-phone_v1.t ready for Jay's 'type' fix to support v1.0 194 | 195 | 0.9 Sat July 07 10:19:00 2003 196 | - Fixed major doc error! 197 | 198 | 0.8 Sat May 17 21:19:00 2003 199 | - Added ability to specify types and tests 200 | - Altered add_type() and remove_type() to accept array ref as well 201 | 202 | 0.7 Tue May 13 08:00:00 2003 203 | - Added emails, tels, lables. Started Binary API 204 | 205 | 0.6 Fri May 9 18:10:00 2003 206 | - More accessor methods added, added the version to everything as well 207 | 208 | 0.5 Fri May 9 08:30:00 2003 209 | - More accessor methods added, docs and tests 210 | 211 | 0.4 Wed May 7 14:48:20 2003 212 | - Lots of new stuff, it's starting to take shape 213 | 214 | 0.3 Wed May 7 10:20:20 2003 215 | - Cleaned up the docs, structure (now in lib/) and Makefile.PL 216 | 217 | 0.2 Tue May 6 12:30:20 2003 218 | - Release for Jay to see 219 | 220 | 0.1 Mon May 5 11:50:20 2003 221 | - original version 222 | -------------------------------------------------------------------------------- /lib/vCard/AddressBook.pm: -------------------------------------------------------------------------------- 1 | package vCard::AddressBook; 2 | 3 | use Moo; 4 | 5 | use vCard; 6 | use Carp; 7 | use Text::vCard; 8 | use Text::vCard::Addressbook; 9 | 10 | =head1 NAME 11 | 12 | vCard::AddressBook - Read, write, and edit vCard address books 13 | 14 | =head1 SYNOPSIS 15 | 16 | use vCard::AddressBook; 17 | 18 | # create the object 19 | my $address_book = vCard::AddressBook->new(); 20 | 21 | # these methods load vCard formatted data 22 | $address_book->load_file('/path/file.vcf'); 23 | $address_book->load_string($string); 24 | 25 | my $vcard = $address_book->add_vcard; # returns a vCard object 26 | $vcard->full_name('Bruce Banner, PhD'); 27 | $vcard->family_names(['Banner']); 28 | $vcard->given_names(['Bruce']); 29 | $vcard->email_addresses([ 30 | { type => ['work'], address => 'bbanner@ssh.secret.army.mil' }, 31 | { type => ['home'], address => 'bbanner@timewarner.com' }, 32 | ]); 33 | 34 | # $address_book->vcards() returns an arrayref of vCard objects 35 | foreach my $vcard (@{ $address_book->vcards() }) { 36 | print $vcard->full_name() . "\n"; 37 | print $vcard->email_addresses->[0]->{address} . "\n"; 38 | } 39 | 40 | # these methods output data in vCard format 41 | my $file = $address_book->as_file('/path/file.vcf'); # write to a file 42 | my $string = $address_book->as_string(); 43 | 44 | 45 | =head1 DESCRIPTION 46 | 47 | A vCard is a digital business card. L and vCard::AddressBook provide an 48 | API for parsing, editing, and creating vCards. 49 | 50 | This module is built on top of L and L 51 | and provides a more intuitive user interface. 52 | 53 | 54 | =head1 ENCODING AND UTF-8 55 | 56 | =head2 Constructor Arguments 57 | 58 | The 'encoding_in' and 'encoding_out' constructor parameters allow you to read 59 | and write vCard files with any encoding. Examples of valid values are 60 | 'UTF-8', 'Latin1', and 'none'. 61 | 62 | Both parameters default to 'UTF-8' and this should just work for the vast 63 | majority of people. The latest vCard RFC 6350 only allows UTF-8 as an encoding 64 | so most people should not need to use either parameter. 65 | 66 | =head2 MIME encodings 67 | 68 | vCard RFC 6350 only allows UTF-8 but it still permits 8bit MIME encoding 69 | schemes such as Quoted-Printable and Base64 which are supported by this module. 70 | 71 | =head2 Getting and setting values on a vCard object 72 | 73 | If you set values on a vCard object they must be decoded values. The 74 | only exception to this rule is if you are messing around with the 75 | 'encoding_out' constructor arg. 76 | 77 | When you get values from a vCard object they will be decoded values. 78 | 79 | 80 | =head1 METHODS 81 | 82 | =cut 83 | 84 | has encoding_in => ( is => 'rw', default => sub {'UTF-8'} ); 85 | has encoding_out => ( is => 'rw', default => sub {'UTF-8'} ); 86 | has vcards => ( is => 'rw', default => sub { [] } ); 87 | 88 | with 'vCard::Role::FileIO'; 89 | 90 | =head2 add_vcard() 91 | 92 | Creates a new vCard object and adds it to the address book. Returns a L 93 | object. 94 | 95 | =cut 96 | 97 | sub add_vcard { 98 | my ($self) = @_; 99 | my $vcard = vCard->new( 100 | { encoding_in => $self->encoding_in, 101 | encoding_out => $self->encoding_out, 102 | } 103 | ); 104 | push @{ $self->vcards }, $vcard; 105 | return $vcard; 106 | } 107 | 108 | =head2 load_file($filename) 109 | 110 | Load and parse the contents of $filename. Returns $self so the method can be 111 | chained. 112 | 113 | =cut 114 | 115 | sub load_file { 116 | my ( $self, $filename ) = @_; 117 | 118 | my $file = $self->_path($filename); 119 | my $string = $file->slurp( $self->_iomode_in ); 120 | 121 | $self->load_string($string); 122 | 123 | return $self; 124 | } 125 | 126 | =head2 load_string($string) 127 | 128 | Load and parse the contents of $string. This method assumes that $string is 129 | decoded (but not MIME decoded). Returns $self so the method can be chained. 130 | 131 | =cut 132 | 133 | sub load_string { 134 | my ( $self, $string ) = @_; 135 | 136 | die <_create_vcards($string); 145 | 146 | return $self; 147 | } 148 | 149 | sub _create_vcards { 150 | my ( $self, $string ) = @_; 151 | 152 | my $vcards_data = Text::vCard::Addressbook->new( 153 | { encoding_in => $self->encoding_in, 154 | encoding_out => $self->encoding_out, 155 | } 156 | )->_pre_process_text($string); 157 | 158 | foreach my $vcard_data (@$vcards_data) { 159 | carp "This file has $vcard_data->{type} data that was not parsed" 160 | unless $vcard_data->{type} =~ /VCARD/i; 161 | 162 | my $vcard = vCard->new( 163 | { encoding_in => $self->encoding_in, 164 | encoding_out => $self->encoding_out, 165 | } 166 | ); 167 | my $text_vcard = Text::vCard->new( 168 | { asData_node => $vcard_data->{properties}, 169 | encoding_out => $self->encoding_out, 170 | } 171 | ); 172 | 173 | $self->_copy_simple_nodes( $text_vcard => $vcard ); 174 | $self->_copy_name( $text_vcard => $vcard ); 175 | $self->_copy_photo( $text_vcard => $vcard ); 176 | $self->_copy_phones( $text_vcard => $vcard ); 177 | $self->_copy_addresses( $text_vcard => $vcard ); 178 | $self->_copy_email_addresses( $text_vcard => $vcard ); 179 | 180 | push @{ $self->vcards }, $vcard; 181 | } 182 | } 183 | 184 | sub _copy_simple_nodes { 185 | my ( $self, $text_vcard, $vcard ) = @_; 186 | 187 | foreach my $node_type ( vCard->_simple_node_types ) { 188 | if ( $node_type eq 'full_name' ) { 189 | next unless $text_vcard->fullname; 190 | $vcard->full_name( $text_vcard->fullname ); 191 | } else { 192 | next unless $text_vcard->$node_type; 193 | $vcard->$node_type( $text_vcard->$node_type ); 194 | } 195 | } 196 | } 197 | 198 | sub _copy_photo { 199 | my ( $self, $text_vcard, $vcard ) = @_; 200 | $vcard->photo( URI->new( $text_vcard->photo ) ); 201 | } 202 | 203 | sub _copy_name { 204 | my ( $self, $text_vcard, $vcard ) = @_; 205 | 206 | my ($node) = $text_vcard->get('n'); 207 | 208 | $vcard->family_names( [ $node->family || () ] ); 209 | $vcard->given_names( [ $node->given || () ] ); 210 | $vcard->other_names( [ $node->middle || () ] ); 211 | $vcard->honorific_prefixes( [ $node->prefixes || () ] ); 212 | $vcard->honorific_suffixes( [ $node->suffixes || () ] ); 213 | } 214 | 215 | sub _copy_phones { 216 | my ( $self, $text_vcard, $vcard ) = @_; 217 | 218 | my @phones; 219 | my $nodes = $text_vcard->get('tel') || []; 220 | 221 | foreach my $node (@$nodes) { 222 | my $phone; 223 | $phone->{type} = scalar $node->types; 224 | $phone->{preferred} = $node->is_pref ? 1 : 0; 225 | $phone->{number} = $node->value; 226 | push @phones, $phone; 227 | } 228 | 229 | $vcard->phones( \@phones ); 230 | } 231 | 232 | sub _copy_addresses { 233 | my ( $self, $text_vcard, $vcard ) = @_; 234 | 235 | my @addresses; 236 | my $nodes = $text_vcard->get('adr') || []; 237 | 238 | foreach my $node (@$nodes) { 239 | my $address; 240 | $address->{type} = scalar $node->types; 241 | $address->{preferred} = $node->is_pref ? 1 : 0; 242 | $address->{po_box} = $node->po_box || undef; 243 | $address->{street} = $node->street || undef; 244 | $address->{city} = $node->city || undef; 245 | $address->{post_code} = $node->post_code || undef; 246 | $address->{region} = $node->region || undef; 247 | $address->{country} = $node->country || undef; 248 | $address->{extended} = $node->extended || undef; 249 | push @addresses, $address; 250 | } 251 | 252 | $vcard->addresses( \@addresses ); 253 | } 254 | 255 | sub _copy_email_addresses { 256 | my ( $self, $text_vcard, $vcard ) = @_; 257 | 258 | my @email_addresses; 259 | my $nodes = $text_vcard->get('email') || []; 260 | 261 | foreach my $node (@$nodes) { 262 | my $email_address; 263 | $email_address->{type} = scalar $node->types; 264 | $email_address->{preferred} = $node->is_pref ? 1 : 0; 265 | $email_address->{address} = $node->value; 266 | push @email_addresses, $email_address; 267 | } 268 | 269 | $vcard->email_addresses( \@email_addresses ); 270 | } 271 | 272 | =head2 as_file($filename) 273 | 274 | Write all the vCards to $filename. Files are written as UTF-8 by default. 275 | Dies if not successful. 276 | 277 | =cut 278 | 279 | sub as_file { 280 | my ( $self, $filename ) = @_; 281 | my $file = $self->_path($filename); 282 | $file->spew( $self->_iomode_out, $self->as_string ); 283 | return $file; 284 | } 285 | 286 | =head2 as_string() 287 | 288 | Returns all the vCards as a single string. 289 | 290 | =cut 291 | 292 | sub as_string { 293 | my ($self) = @_; 294 | my $string = ''; 295 | $string .= $_->as_string for @{ $self->vcards }; 296 | return $string; 297 | } 298 | 299 | =head1 AUTHOR 300 | 301 | Eric Johnson (kablamo), github ~!at!~ iijo dot org 302 | 303 | =head1 ACKNOWLEDGEMENTS 304 | 305 | Thanks to L for making this module possible by 306 | donating a significant amount of developer time. 307 | 308 | =cut 309 | 310 | 1; 311 | -------------------------------------------------------------------------------- /lib/Text/vCard/Addressbook.pm: -------------------------------------------------------------------------------- 1 | package Text::vCard::Addressbook; 2 | 3 | use Carp; 4 | use strict; 5 | use warnings; 6 | use Path::Tiny; 7 | use Text::vFile::asData; 8 | use Text::vCard; 9 | 10 | # See this module for your basic parser functions 11 | use base qw(Text::vFile::asData); 12 | 13 | =head1 NAME 14 | 15 | Text::vCard::Addressbook - Parse, edit, and create vCard address books (RFC 2426) 16 | 17 | =head1 WARNING 18 | 19 | L is built on top of this module and provides a more 20 | intuitive user interface. Please try that module first. 21 | 22 | =head1 SYNOPSIS 23 | 24 | use Text::vCard::Addressbook; 25 | 26 | # To read an existing address book file: 27 | 28 | my $address_book = Text::vCard::Addressbook->new({ 29 | 'source_file' => '/path/to/address_book.vcf', 30 | }); 31 | 32 | foreach my $vcard ( $address_book->vcards() ) { 33 | print "Got card for " . $vcard->fullname() . "\n"; 34 | } 35 | 36 | # To create a new address book file: 37 | 38 | my $address_book = Text::vCard::Addressbook->new(); 39 | my $vcard = $address_book->add_vcard; 40 | $vcard->fullname('Foo Bar'); 41 | $vcard->EMAIL('foo@bar.com'); 42 | 43 | open my $out, '>:encoding(UTF-8)', 'new_address_book.vcf' or die; 44 | print $out $address_book->export; 45 | 46 | 47 | =head1 DESCRIPTION 48 | 49 | This package provides an API to reading / editing and creating multiple vCards. 50 | A vCard is an electronic business card. This package has been developed based 51 | on rfc2426. 52 | 53 | You will find that many applications (Apple Address book, MS Outlook, Evolution 54 | etc) can export and import vCards. 55 | 56 | 57 | =head1 ENCODING AND UTF-8 58 | 59 | =head2 Constructor Arguments 60 | 61 | The 'encoding_in' and 'encoding_out' constructor arguments allow you to read 62 | and write vCard files with any encoding. Examples of valid values are 63 | 'UTF-8', 'Latin1', and 'none'. 64 | 65 | Both values default to 'UTF-8' and this should just work for the vast majority 66 | of people. The latest vCard RFC 6350 only allows UTF-8 as an encoding so most 67 | people should not need to use either of these constructor arguments. 68 | 69 | =head2 MIME encodings 70 | 71 | vCard RFC 6350 only allows UTF-8 but it still permits 8bit MIME encoding 72 | schemes such as Quoted-Printable and Base64 which are supported by this module. 73 | 74 | =head2 Manually setting values on a Text::vCard or Text::vCard::Node object 75 | 76 | If you manually set values on a Text::vCard or Text::vCard::Node object they 77 | must be decoded values. The only exception to this rule is if you are messing 78 | around with the 'encoding_out' constructor arg. 79 | 80 | 81 | =head1 METHODS FOR LOADING VCARDS 82 | 83 | =head2 load() 84 | 85 | my $address_book = Text::vCard::Addressbook->load( 86 | [ 'foo.vCard', 'Addresses.vcf' ], # list of files to load 87 | ); 88 | 89 | This method will croak if it is unable to read in any of the files. 90 | 91 | =cut 92 | 93 | sub load { 94 | my ( $proto, $filenames, $constructor_args ) = @_; 95 | 96 | my $self = __PACKAGE__->new($constructor_args); 97 | 98 | foreach my $filename ( @{$filenames} ) { 99 | 100 | croak "Unable to read file $filename" unless -r $filename; 101 | 102 | my $file = $self->_path($filename); 103 | my $string = $file->slurp( $self->_iomode_in ); 104 | 105 | die <import_data($string); 114 | } 115 | 116 | return $self; 117 | 118 | } 119 | 120 | =head2 import_data() 121 | 122 | $address_book->import_data($string); 123 | 124 | This method imports data directly from a string. $string is assumed to be 125 | decoded (but not MIME decoded). 126 | 127 | =cut 128 | 129 | sub import_data { 130 | my ( $self, $value ) = @_; 131 | 132 | $self->_process_text($value); 133 | } 134 | 135 | =head2 new() 136 | 137 | # Create a new (empty) address book 138 | my $address_book = Text::vCard::Addressbook->new(); 139 | 140 | # Load vcards from a single file 141 | my $address_book = Text::vCard::Addressbook->new({ 142 | source_file => '/path/to/address_book.vcf' 143 | }); 144 | 145 | # Load vcards from a a string 146 | my $address_book = Text::vCard::Addressbook->new({ 147 | source_text => $source_text 148 | }); 149 | 150 | This method will croak if it is unable to read the source_file. 151 | 152 | The constructor accepts 'encoding_in' and 'encoding_out' attributes. The 153 | default values for both are 'UTF-8'. You can set them to 'none' if 154 | you don't want your output encoded with Encode::encode(). But be aware the 155 | latest vCard RFC 6350 mandates UTF-8. 156 | 157 | =cut 158 | 159 | sub new { 160 | my ( $proto, $conf ) = @_; 161 | my $class = ref($proto) || $proto; 162 | my $self = {}; 163 | 164 | bless( $self, $class ); 165 | 166 | # create some where to store out individual vCard objects 167 | $self->{'cards'} = []; 168 | $self->{encoding_in} = $conf->{encoding_in} || 'UTF-8'; 169 | $self->{encoding_out} = $conf->{encoding_out} || 'UTF-8'; 170 | 171 | # slurp in file contents 172 | if ( defined $conf->{'source_file'} ) { 173 | 174 | croak "Unable to read file $conf->{'source_file'}\n" 175 | unless -r $conf->{'source_file'}; 176 | 177 | my $filename = $conf->{source_file}; 178 | my $file = $self->_path($filename); 179 | $conf->{source_text} = $file->slurp( $self->_iomode_in ); 180 | } 181 | 182 | # Process the text if we have it. 183 | $self->_process_text( $conf->{'source_text'} ) 184 | if defined $conf->{'source_text'}; 185 | 186 | return $self; 187 | } 188 | 189 | =head1 OTHER METHODS 190 | 191 | =head2 add_vcard() 192 | 193 | my $vcard = $address_book->add_vcard(); 194 | 195 | This method creates a new empty L object, stores it in the 196 | address book and return it so you can add data to it. 197 | 198 | =cut 199 | 200 | sub add_vcard { 201 | my $self = shift; 202 | my $vcard = Text::vCard->new( { encoding_out => $self->{encoding_out} } ); 203 | push( @{ $self->{cards} }, $vcard ); 204 | return $vcard; 205 | } 206 | 207 | =head2 vcards() 208 | 209 | my $vcards = $address_book->vcards(); 210 | my @vcards = $address_book->vcards(); 211 | 212 | This method returns a reference to an array or an array of 213 | vcards in this address book. This could be an empty list 214 | if there are no entries in the address book. 215 | 216 | =cut 217 | 218 | sub vcards { 219 | my $self = shift; 220 | return wantarray ? @{ $self->{cards} } : $self->{cards}; 221 | } 222 | 223 | =head2 set_encoding() 224 | 225 | DEPRECATED. Use the 'encoding_in' and 'encoding_out' constructor arguments. 226 | 227 | =cut 228 | 229 | sub set_encoding { 230 | my ( $self, $coding ) = @_; 231 | $self->{'encoding'} |= ''; 232 | $self->{'encoding'} = ";charset=$coding" if ( defined $coding ); 233 | return $self->{'encoding'}; 234 | die "DEPRECATED. Use the 'encoding_in' and 'encoding_out'" 235 | . " constructor arguments"; 236 | } 237 | 238 | =head2 export() 239 | 240 | my $string = $address_book->export() 241 | 242 | This method returns the vcard data as a string in the vcf file format. 243 | 244 | Please note there is no validation, you must ensure that the correct nodes 245 | (FN,N,VERSION) are already added to each vcard if you want to comply with 246 | RFC 2426. 247 | 248 | =cut 249 | 250 | sub export { 251 | my $self = shift; 252 | my $string = ''; 253 | $string .= $_->as_string for $self->vcards; 254 | return $string; 255 | } 256 | 257 | # PRIVATE METHODS 258 | 259 | # PerlIO layers should look like ':encoding(UTF-8)' 260 | # The ':encoding()' part does character set and encoding transformations. 261 | # Without it you are just declaring the stream to be of a certain encoding. 262 | # See PerlIO, PerlIO::encoding docs. 263 | sub _iomode_in { 264 | my ($self) = @_; 265 | return { binmode => ':raw' } if $self->{encoding_in} eq 'none'; 266 | return { binmode => ':raw:encoding(' . $self->{encoding_in} . ')' }; 267 | } 268 | 269 | # Filename can be a string, a Path::Tiny obj, or a Path::Class obj. 270 | # Returns a Path::Tiny obj. 271 | sub _path { 272 | my ( $self, $filename ) = @_; 273 | return ref $filename eq 'Path::Class::File' # 274 | ? path("$filename") 275 | : path($filename); # works for strings and Path::Tiny objects 276 | } 277 | 278 | # Process a chunk of text, create Text::vCard objects and store in the address book 279 | sub _pre_process_text { 280 | my ( $self, $text ) = @_; 281 | 282 | if ( $text =~ /quoted-printable/i ) { 283 | 284 | # Edge case for 2.1 version 285 | # 286 | # http://tools.ietf.org/html/rfc2045#section-6.7 point (5), 287 | # lines containing quoted-printable encoded data can contain soft line 288 | # breaks. These are indicated as single '=' sign at the end of the 289 | # line. 290 | # 291 | # No longer needed in version 3.0: 292 | # http://tools.ietf.org/html/rfc2426 point (5) 293 | # 294 | # 'perldoc perlport' says using \r\n is wrong and confusing for a few 295 | # reasons but mainly because the value of \n is different on different 296 | # operating systems. It recommends \x0D\x0A instead. 297 | 298 | my $out; 299 | my $inside = 0; 300 | foreach my $line ( split( "\x0D\x0A", $text ) ) { 301 | 302 | if ($inside) { 303 | if ( $line =~ /=$/ ) { 304 | $line =~ s/=$//; 305 | } else { 306 | $inside = 0; 307 | } 308 | } 309 | 310 | if ( $line =~ /ENCODING=QUOTED-PRINTABLE/i ) { 311 | $inside = 1; 312 | $line =~ s/=$//; 313 | } 314 | $out .= $line . "\x0D\x0A"; 315 | } 316 | $text = $out; 317 | 318 | } 319 | 320 | # Add error checking here ? 321 | my $asData = Text::vFile::asData->new; 322 | $asData->preserve_params(1); 323 | 324 | my @lines = split "\x0D\x0A", $text; 325 | my @lines_with_newlines = map { $_ . "\x0D\x0A" } @lines; 326 | return $asData->parse_lines(@lines_with_newlines)->{objects}; 327 | } 328 | 329 | sub _process_text { 330 | my ( $self, $text ) = @_; 331 | 332 | my $cards = $self->_pre_process_text($text); 333 | 334 | foreach my $card (@$cards) { 335 | 336 | # Run through each card in the data 337 | if ( $card->{'type'} =~ /VCARD/i ) { 338 | my $vcard = Text::vCard->new( 339 | { 'asData_node' => $card->{'properties'}, 340 | encoding_in => $self->{encoding_in}, 341 | encoding_out => $self->{encoding_out} 342 | } 343 | ); 344 | push( @{ $self->{'cards'} }, $vcard ); 345 | } else { 346 | carp 347 | "This file contains $card->{'type'} data which was not parsed"; 348 | } 349 | } 350 | 351 | return $self->{cards}; 352 | } 353 | 354 | =head1 AUTHOR 355 | 356 | Leo Lapworth, LLAP@cuckoo.org 357 | Eric Johnson (kablamo), github ~!at!~ iijo dot org 358 | 359 | =head1 COPYRIGHT 360 | 361 | Copyright (c) 2003 Leo Lapworth. All rights reserved. 362 | This program is free software; you can redistribute 363 | it and/or modify it under the same terms as Perl itself. 364 | 365 | =head1 ACKNOWLEDGEMENTS 366 | 367 | The authors of L for making my life so much easier. 368 | 369 | =head1 SEE ALSO 370 | 371 | L, L 372 | 373 | =cut 374 | 375 | 1; 376 | -------------------------------------------------------------------------------- /lib/vCard.pm: -------------------------------------------------------------------------------- 1 | package vCard; 2 | 3 | use Moo; 4 | 5 | use Carp; 6 | use Path::Tiny; 7 | use Text::vCard; 8 | use vCard::AddressBook; 9 | use URI; 10 | 11 | =head1 NAME 12 | 13 | vCard - Read, write, and edit vCards 14 | 15 | =head1 SYNOPSIS 16 | 17 | use vCard; 18 | 19 | # create the object 20 | my $vcard = vCard->new; 21 | 22 | # these methods load vCard data 23 | # (see method documentation for details) 24 | $vcard->load_file($filename); 25 | $vcard->load_string($string); 26 | $vcard->load_hashref($hashref); 27 | 28 | # simple getters/setters 29 | $vcard->full_name('Bruce Banner, PhD'); 30 | $vcard->title('Research Scientist'); 31 | $vcard->photo('http://example.com/bbanner.gif'); 32 | 33 | # complex getters/setters 34 | $vcard->phones([ 35 | { type => ['work', 'text'], number => '651-290-1234', preferred => 1 }, 36 | { type => ['home'], number => '651-290-1111' } 37 | ]); 38 | $vcard->email_addresses([ 39 | { type => ['work'], address => 'bbanner@ssh.secret.army.mil' }, 40 | { type => ['home'], address => 'bbanner@timewarner.com' }, 41 | ]); 42 | 43 | # these methods output data in vCard format 44 | my $file = $vcard->as_file($filename); # writes to $filename 45 | my $string = $vcard->as_string; # returns a string 46 | 47 | 48 | =head1 DESCRIPTION 49 | 50 | A vCard is a digital business card. vCard and L provide an 51 | API for parsing, editing, and creating vCards. 52 | 53 | This module is built on top of L. It provides a more intuitive user 54 | interface. 55 | 56 | To handle an address book with several vCard entries in it, start with 57 | L and then come back to this module. 58 | 59 | Note that the vCard RFC requires version() and full_name(). This module does 60 | not check or warn if these conditions have not been met. 61 | 62 | 63 | =head1 ENCODING AND UTF-8 64 | 65 | See the 'ENCODING AND UTF-8' section of L. 66 | 67 | 68 | =head1 METHODS 69 | 70 | =cut 71 | 72 | has encoding_in => ( is => 'rw', default => sub {'UTF-8'} ); 73 | has encoding_out => ( is => 'rw', default => sub {'UTF-8'} ); 74 | has _data => ( is => 'rw', default => sub { { version => '4.0' } } ); 75 | 76 | with 'vCard::Role::FileIO'; 77 | 78 | =head2 load_hashref($hashref) 79 | 80 | $hashref should look like this: 81 | 82 | full_name => 'Bruce Banner, PhD', 83 | given_names => ['Bruce'], 84 | family_names => ['Banner'], 85 | title => 'Research Scientist', 86 | photo => 'http://example.com/bbanner.gif', 87 | phones => [ 88 | { type => ['work'], number => '651-290-1234', preferred => 1 }, 89 | { type => ['cell'], number => '651-290-1111' }, 90 | }, 91 | addresses => [ 92 | { type => ['work'], ... }, 93 | { type => ['home'], ... }, 94 | ], 95 | email_addresses => [ 96 | { type => ['work'], address => 'bbanner@shh.secret.army.mil' }, 97 | { type => ['home'], address => 'bbanner@timewarner.com' }, 98 | ], 99 | 100 | Returns $self in case you feel like chaining. 101 | 102 | =cut 103 | 104 | sub load_hashref { 105 | my ( $self, $hashref ) = @_; 106 | $self->_data($hashref); 107 | 108 | $self->_data->{version} = '4.0' 109 | unless $self->_data->{version}; 110 | 111 | $self->_data->{photo} = URI->new( $self->_data->{photo} ) 112 | unless ref $self->_data->{photo} =~ /^URI/; 113 | 114 | return $self; 115 | } 116 | 117 | =head2 load_file($filename) 118 | 119 | Returns $self in case you feel like chaining. 120 | 121 | =cut 122 | 123 | sub load_file { 124 | my ( $self, $filename ) = @_; 125 | 126 | my $addressBook = vCard::AddressBook->new({ 127 | encoding_in => $self->encoding_in, 128 | encoding_out => $self->encoding_out, 129 | }); 130 | my $vcard = $addressBook->load_file($filename)->vcards->[0]; 131 | 132 | $self->_data($vcard->_data); 133 | 134 | return $self; 135 | } 136 | 137 | =head2 load_string($string) 138 | 139 | Returns $self in case you feel like chaining. This method assumes $string is 140 | decoded (but not MIME decoded). 141 | 142 | =cut 143 | 144 | sub load_string { 145 | my ( $self, $string ) = @_; 146 | 147 | my $addressBook = vCard::AddressBook->new({ 148 | encoding_in => $self->encoding_in, 149 | encoding_out => $self->encoding_out, 150 | }); 151 | my $vcard = $addressBook->load_string($string)->vcards->[0]; 152 | 153 | $self->_data($vcard->_data); 154 | 155 | return $self; 156 | } 157 | 158 | =head2 as_string() 159 | 160 | Returns the vCard as a string. 161 | 162 | =cut 163 | 164 | sub as_string { 165 | my ($self) = @_; 166 | my $vcard = Text::vCard->new( { encoding_out => $self->encoding_out } ); 167 | 168 | my $phones = $self->_data->{phones}; 169 | my $addresses = $self->_data->{addresses}; 170 | my $email_addresses = $self->_data->{email_addresses}; 171 | 172 | $self->_build_simple_nodes( $vcard, $self->_data ); 173 | $self->_build_name_node( $vcard, $self->_data ); 174 | $self->_build_org_node( $vcard, $self->_data->{org} ) if $self->_data->{org}; 175 | $self->_build_phone_nodes( $vcard, $phones ) if $phones; 176 | $self->_build_address_nodes( $vcard, $addresses ) if $addresses; 177 | $self->_build_email_address_nodes( $vcard, $email_addresses ) 178 | if $email_addresses; 179 | 180 | return $vcard->as_string; 181 | } 182 | 183 | sub _simple_node_types { 184 | qw/full_name nickname title photo birthday timezone version/; 185 | #geo, too? 186 | } 187 | 188 | sub _build_simple_nodes { 189 | my ( $self, $vcard, $data ) = @_; 190 | 191 | foreach my $node_type ( $self->_simple_node_types ) { 192 | if ( $node_type eq 'full_name' ) { 193 | next unless $data->{full_name}; 194 | $vcard->fullname( $data->{full_name} ); 195 | } else { 196 | next unless $data->{$node_type}; 197 | $vcard->$node_type( $data->{$node_type} ); 198 | } 199 | } 200 | } 201 | 202 | sub _build_complex_node { 203 | my ( $self, $vcard, $node_type, $data ) = @_; 204 | croak '$data must be HASHREF' unless ref $data eq 'HASH'; 205 | $vcard->add_node( { node_type => $node_type, data => [ $data ] } ); 206 | } 207 | 208 | sub _build_org_node { 209 | my ( $self, $vcard, $data ) = @_; 210 | 211 | my $value = join ';', @{ $data || [] }; 212 | $self->_build_complex_node( $vcard, 'ORG', { value => $value } ); 213 | } 214 | 215 | sub _build_name_node { 216 | my ( $self, $vcard, $data ) = @_; 217 | 218 | my $value = join ',', @{ $data->{family_names} || [] }; 219 | $value .= ';' . join ',', @{ $data->{given_names} || [] }; 220 | $value .= ';' . join ',', @{ $data->{other_names} || [] }; 221 | $value .= ';' . join ',', @{ $data->{honorific_prefixes} || [] }; 222 | $value .= ';' . join ',', @{ $data->{honorific_suffixes} || [] }; 223 | 224 | 225 | $self->_build_complex_node( $vcard, 'N', { value => $value } ) 226 | if $value ne ';;;;'; 227 | } 228 | 229 | sub _build_phone_nodes { 230 | my ( $self, $vcard, $phones ) = @_; 231 | 232 | foreach my $phone (@$phones) { 233 | 234 | # TODO: better error handling 235 | croak "'number' attr missing from 'phones'" unless $phone->{number}; 236 | croak "'type' attr in 'phones' should be an arrayref" 237 | if ( $phone->{type} && ref( $phone->{type} ) ne 'ARRAY' ); 238 | 239 | my $type = $phone->{type} || []; 240 | my $preferred = $phone->{preferred}; 241 | my $number = $phone->{number}; 242 | 243 | my $params = []; 244 | push @$params, { type => $_ } foreach @$type; 245 | push @$params, { pref => $preferred } if $preferred; 246 | 247 | $self->_build_complex_node( $vcard, 'TEL', { params => $params, value => $number } ); 248 | } 249 | } 250 | 251 | sub _build_address_nodes { 252 | my ( $self, $vcard, $addresses ) = @_; 253 | 254 | foreach my $address (@$addresses) { 255 | 256 | croak "'type' attr in 'addresses' should be an arrayref" 257 | if ( $address->{type} && ref( $address->{type} ) ne 'ARRAY' ); 258 | 259 | my $type = $address->{type} || []; 260 | my $preferred = $address->{preferred}; 261 | 262 | my $params = []; 263 | push @$params, { type => $_ } foreach @$type; 264 | push @$params, { pref => $preferred } if $preferred; 265 | 266 | my $value = join ';', 267 | $address->{pobox} || '', 268 | $address->{extended} || '', 269 | $address->{street} || '', 270 | $address->{city} || '', 271 | $address->{region} || '', 272 | $address->{post_code} || '', 273 | $address->{country} || ''; 274 | 275 | $self->_build_complex_node( $vcard, 'ADR', { params => $params, value => $value } ); 276 | } 277 | } 278 | 279 | sub _build_email_address_nodes { 280 | my ( $self, $vcard, $email_addresses ) = @_; 281 | 282 | foreach my $email_address (@$email_addresses) { 283 | 284 | # TODO: better error handling 285 | croak "'address' attr missing from 'email_addresses'" 286 | unless $email_address->{address}; 287 | croak "'type' attr in 'email_addresses' should be an arrayref" 288 | if ( $email_address->{type} 289 | && ref( $email_address->{type} ) ne 'ARRAY' ); 290 | 291 | my $type = $email_address->{type} || []; 292 | my $preferred = $email_address->{preferred}; 293 | 294 | my $params = []; 295 | push @$params, { type => $_ } foreach @$type; 296 | push @$params, { pref => $preferred } if $preferred; 297 | 298 | # TODO: better error handling 299 | my $value = $email_address->{address}; 300 | 301 | $self->_build_complex_node( $vcard, 'EMAIL', { params => $params, value => $value } ); 302 | } 303 | } 304 | 305 | =head2 as_file($filename) 306 | 307 | Write data in vCard format to $filename. 308 | 309 | Dies if not successful. 310 | 311 | =cut 312 | 313 | sub as_file { 314 | my ( $self, $filename ) = @_; 315 | my $file = $self->_path($filename); 316 | $file->spew( $self->_iomode_out, $self->as_string ); 317 | return $file; 318 | } 319 | 320 | =head1 SIMPLE GETTERS/SETTERS 321 | 322 | These methods accept and return strings. 323 | 324 | =head2 version() 325 | 326 | Version number of the vcard. Defaults to '4.0' 327 | 328 | =head2 full_name() 329 | 330 | A person's entire name as they would like to see it displayed. 331 | 332 | =head2 title() 333 | 334 | A person's position or job. 335 | 336 | =head2 nickname() 337 | 338 | A person's nickname. 339 | 340 | =head2 photo() 341 | 342 | This should be a link. Accepts a string or a URI object. This method 343 | always returns a L object. 344 | 345 | TODO: handle binary images using the data uri schema 346 | 347 | =head2 birthday() 348 | 349 | =head2 timezone() 350 | 351 | 352 | =head1 COMPLEX GETTERS/SETTERS 353 | 354 | These methods accept and return array references rather than simple strings. 355 | 356 | =head2 family_names() 357 | 358 | Accepts/returns an arrayref of family names (aka surnames). 359 | 360 | =head2 given_names() 361 | 362 | Accepts/returns an arrayref. 363 | 364 | =head2 other_names() 365 | 366 | Accepts/returns an arrayref of names which don't qualify as family_names or 367 | given_names. 368 | 369 | =head2 honorific_prefixes() 370 | 371 | Accepts/returns an arrayref. eg C<[ 'Dr.' ]> 372 | 373 | =head2 honorific_suffixes() 374 | 375 | Accepts/returns an arrayref. eg C<[ 'Jr.', 'MD' ]> 376 | 377 | =head2 phones() 378 | 379 | Accepts/returns an arrayref that looks like: 380 | 381 | [ 382 | { type => ['work'], number => '651-290-1234', preferred => 1 }, 383 | { type => ['cell'], number => '651-290-1111' }, 384 | ] 385 | 386 | =head2 addresses() 387 | 388 | Accepts/returns an arrayref that looks like: 389 | 390 | [ 391 | { type => ['work'], street => 'Main St', preferred => 0 }, 392 | { type => ['home'], 393 | pobox => 1234, 394 | extended => 'asdf', 395 | street => 'Army St', 396 | city => 'Desert Base', 397 | region => '', 398 | post_code => '', 399 | country => 'USA', 400 | preferred => 1, 401 | }, 402 | ] 403 | 404 | =head2 email_addresses() 405 | 406 | Accepts/returns an arrayref that looks like: 407 | 408 | [ 409 | { type => ['work'], address => 'bbanner@ssh.secret.army.mil' }, 410 | { type => ['home'], address => 'bbanner@timewarner.com', preferred => 1 }, 411 | ] 412 | 413 | =cut 414 | 415 | sub version { shift->_setget( 'version', @_ ) } 416 | sub full_name { shift->_setget( 'full_name', @_ ) } 417 | sub family_names { shift->_setget( 'family_names', @_ ) } 418 | sub given_names { shift->_setget( 'given_names', @_ ) } 419 | sub other_names { shift->_setget( 'other_names', @_ ) } 420 | sub nickname { shift->_setget( 'nickname', @_ ) } 421 | sub honorific_prefixes { shift->_setget( 'honorific_prefixes', @_ ) } 422 | sub honorific_suffixes { shift->_setget( 'honorific_suffixes', @_ ) } 423 | sub title { shift->_setget( 'title', @_ ) } 424 | sub photo { shift->_setget( 'photo', @_ ) } 425 | sub birthday { shift->_setget( 'birthday', @_ ) } 426 | sub timezone { shift->_setget( 'timezone', @_ ) } 427 | sub phones { shift->_setget( 'phones', @_ ) } 428 | sub addresses { shift->_setget( 'addresses', @_ ) } 429 | sub email_addresses { shift->_setget( 'email_addresses', @_ ) } 430 | sub organization { shift->_setget( 'organization', @_ ) } 431 | 432 | sub _setget { 433 | my ( $self, $attr, $value ) = @_; 434 | 435 | $value = URI->new($value) 436 | if $value && $attr eq 'photo' && ref $value =~ /^URI/; 437 | 438 | $self->_data->{$attr} = $value if $value; 439 | 440 | return $self->_data->{$attr}; 441 | } 442 | 443 | =head1 AUTHOR 444 | 445 | Eric Johnson (kablamo), github ~!at!~ iijo dot org 446 | 447 | =head1 ACKNOWLEDGEMENTS 448 | 449 | Thanks to L for making this module possible by 450 | donating a significant amount of developer time. 451 | 452 | =cut 453 | 454 | 1; 455 | -------------------------------------------------------------------------------- /lib/Text/vCard.pm: -------------------------------------------------------------------------------- 1 | package Text::vCard; 2 | 3 | use 5.006; 4 | use Carp; 5 | use strict; 6 | use warnings; 7 | use Text::vFile::asData 0.07; 8 | use Text::vCard::Node; 9 | 10 | # See this module for your basic parser functions 11 | use base qw(Text::vFile::asData); 12 | use vars qw (%lookup %node_aliases @simple); 13 | 14 | # If the node's data does not break down use this 15 | my @default_field = qw(value); 16 | 17 | # If it does use these 18 | %lookup = ( 19 | 'ADR' => [ 20 | 'po_box', 'extended', 'street', 'city', 21 | 'region', 'post_code', 'country', 'label' 22 | ], 23 | 'N' => [ 'family', 'given', 'middle', 'prefixes', 'suffixes' ], 24 | 'GEO' => [ 'lat', 'long' ], 25 | 'ORG' => [ 'name', 'unit' ], 26 | ); 27 | 28 | %node_aliases = ( 29 | 'FULLNAME' => 'FN', 30 | 'BIRTHDAY' => 'BDAY', 31 | 'TIMEZONE' => 'TZ', 32 | 'PHONES' => 'TEL', 33 | 'ADDRESSES' => 'ADR', 34 | 'NAME' => 'N', # To be deprecated as clashes with RFC 35 | 'MONIKER' => 'N', 36 | ); 37 | 38 | # Generate all our simple methods 39 | @simple 40 | = qw(FN BDAY MAILER TZ TITLE ROLE NOTE PRODID REV SORT-STRING UID URL CLASS FULLNAME BIRTHDAY TIMEZONE NAME EMAIL NICKNAME PHOTO); 41 | 42 | # Now we want lowercase as well 43 | map { push( @simple, lc($_) ) } @simple; 44 | 45 | # Generate the methods 46 | { 47 | no strict 'refs'; 48 | no warnings 'redefine'; 49 | 50 | # 'version' handled separately 51 | # to prevent conflict with ExtUtils::MakeMaker 52 | # and $VERSION 53 | for my $node ( @simple, "version" ) { 54 | *$node = sub { 55 | my ( $self, $value ) = @_; 56 | 57 | # See if we have it already 58 | my $nodes = $self->get($node); 59 | if ( !defined $nodes && $value ) { 60 | 61 | # Add it as a node if not exists and there is a value 62 | $self->add_node( { 'node_type' => $node, } ); 63 | 64 | # Get it out again 65 | $nodes = $self->get($node); 66 | } 67 | 68 | if ( scalar($nodes) && $value ) { 69 | 70 | # Set it 71 | $nodes->[0]->value($value); 72 | } 73 | 74 | return $nodes->[0]->value() if scalar($nodes); 75 | return undef; 76 | } 77 | } 78 | } 79 | 80 | =head1 NAME 81 | 82 | Text::vCard - Edit and create vCards (RFC 2426) 83 | 84 | =head1 WARNING 85 | 86 | L and L are built on top of this module and provide 87 | a more intuitive user interface. Please try those modules first. 88 | 89 | =head1 SYNOPSIS 90 | 91 | use Text::vCard; 92 | my $cards 93 | = Text::vCard->new( { 'asData_node' => $objects_node_from_asData, } ); 94 | 95 | =head1 DESCRIPTION 96 | 97 | A vCard is an electronic business card. 98 | 99 | This package is for a single vCard (person / record / set of address 100 | information). It provides an API to editing and creating vCards, or supplied 101 | a specific piece of the Text::vFile::asData results it generates a vCard 102 | with that content. 103 | 104 | You should really use L as this handles creating 105 | vCards from an existing file for you. 106 | 107 | =head1 METHODS 108 | 109 | =head2 new() 110 | 111 | use Text::vCard; 112 | 113 | my $new_vcard = Text::vCard->new(); 114 | 115 | my $existing_vcard 116 | = Text::vCard->new( { 'asData_node' => $objects_node_from_asData, } ); 117 | 118 | =cut 119 | 120 | sub new { 121 | my ( $proto, $conf ) = @_; 122 | my $class = ref($proto) || $proto; 123 | my $self = {}; 124 | 125 | bless( $self, $class ); 126 | 127 | $self->{encoding_out} = $conf->{encoding_out} || 'UTF-8'; 128 | 129 | my %nodes; 130 | $self->{nodes} = \%nodes; 131 | 132 | if ( defined $conf->{'asData_node'} ) { 133 | 134 | # Have a vcard data node being passed in 135 | while ( my ( $node_type, $data ) = each %{ $conf->{'asData_node'} } ) 136 | { 137 | my $group; 138 | if ( $node_type =~ /\./ ) { 139 | 140 | # Version 3.0 supports group types, we do not 141 | # so remove everything before '.' 142 | ( $group, $node_type ) = $node_type =~ /(.+)\.(.*)/; 143 | } 144 | 145 | # Deal with each type (ADR, FN, TEL etc) 146 | $self->_add_node( 147 | { 'node_type' => $node_type, 148 | 'data' => $data, 149 | 'group' => $group, 150 | } 151 | ); 152 | } 153 | } # else we're creating a new vCard 154 | 155 | return $self; 156 | } 157 | 158 | =head2 add_node() 159 | 160 | my $address = $vcard->add_node( { 'node_type' => 'ADR', } ); 161 | 162 | This creates a new address (a L object) in the vCard 163 | which you can then call the address methods on. See below for what options are available. 164 | 165 | The node_type parameter must conform to the vCard spec format (e.g. ADR not address) 166 | 167 | =cut 168 | 169 | sub add_node { 170 | my ( $self, $conf ) = @_; 171 | croak 'Must supply a node_type' 172 | unless defined $conf && defined $conf->{'node_type'}; 173 | unless ( defined $conf->{data} ) { 174 | my %empty; 175 | my @data = ( \%empty ); 176 | $conf->{'data'} = \@data; 177 | } 178 | 179 | $self->_add_node($conf); 180 | } 181 | 182 | =head2 get() 183 | 184 | The following method allows you to extract the contents from the vCard. 185 | 186 | # get all elements 187 | $nodes = $vcard->get('tel'); 188 | 189 | # Just get the home address 190 | my $nodes = $vcard->get( 191 | { 'node_type' => 'addresses', 192 | 'types' => 'home', 193 | } 194 | ); 195 | 196 | # get all phone number that matches serveral types 197 | my @types = qw(work home); 198 | my $nodes = $vcard->get( 199 | { 'node_type' => 'tel', 200 | 'types' => \@types, 201 | } 202 | ); 203 | 204 | 205 | Either an array or array ref is returned, containing 206 | L objects. If there are no results of 'node_type' 207 | undef is returned. 208 | 209 | Supplied with a scalar or an array ref the methods 210 | return a list of nodes of a type, where relevant. If any 211 | of the elements is the prefered element it will be 212 | returned as the first element of the list. 213 | 214 | =cut 215 | 216 | sub get { 217 | my ( $self, $conf ) = @_; 218 | carp "You did not supply an element type" unless defined $conf; 219 | if ( ref($conf) eq 'HASH' ) { 220 | return $self->get_of_type( $conf->{'node_type'}, $conf->{'types'} ) 221 | if defined $conf->{'types'}; 222 | return $self->get_of_type( $conf->{'node_type'} ); 223 | } else { 224 | return $self->get_of_type($conf); 225 | } 226 | } 227 | 228 | =head2 get_simple_type() 229 | 230 | The following method is a convenience wrapper for accessing simple elements. 231 | 232 | $value = $vcard->get_simple_type( 'email', [ 'internet', 'work' ] ); 233 | 234 | If multiple elements match, then only the first is returned. If the object 235 | isn't found, or doesn't have a simple value, then undef is returned. 236 | 237 | The argument type may be ommitted, it can be a scalar, or it can be an 238 | array reference if multiple types are selected. 239 | 240 | =cut 241 | 242 | sub get_simple_type { 243 | my ( $self, $node_type, $types ) = @_; 244 | carp "You did not supply an element type" unless defined $node_type; 245 | 246 | my %hash = ( 'node_type', $node_type ); 247 | $hash{'types'} = $types if defined $types; 248 | my $node = $self->get( \%hash ); 249 | return undef unless $node && @{$node} > 0 && exists $node->[0]->{'value'}; 250 | 251 | $node->[0]->{'value'}; 252 | } 253 | 254 | =head2 nodes 255 | 256 | my $addresses = $vcard->get( { 'node_type' => 'address' } ); 257 | 258 | my $first_address = $addresses->[0]; 259 | 260 | # get the value 261 | print $first_address->street(); 262 | 263 | # set the value 264 | $first_address->street('Barney Rubble'); 265 | 266 | # See if it is part of a group 267 | if ( $first_address->group() ) { 268 | print 'Group: ' . $first_address->group(); 269 | } 270 | 271 | According to the RFC the following 'simple' nodes should only have one 272 | element, this is not enforced by this module, so for example you can 273 | have multiple URL's if you wish. 274 | 275 | =head2 simple nodes 276 | 277 | For simple nodes, you can also access the first node in the following way: 278 | 279 | my $fn = $vcard->fullname(); 280 | # or setting 281 | $vcard->fullname('new name'); 282 | 283 | The node will be automatically created if it does not exist and you 284 | supplied a value. undef is returned if the node does not 285 | exist. Simple nodes can be called as all upper or all lowercase method 286 | names. 287 | 288 | vCard Spec: 'simple' Alias 289 | -------------------- -------- 290 | FN fullname 291 | BDAY birthday 292 | MAILER 293 | TZ timezone 294 | TITLE 295 | ROLE 296 | NOTE 297 | PRODID 298 | REV 299 | SORT-STRING 300 | UID 301 | URL 302 | CLASS 303 | EMAIL 304 | NICKNAME 305 | PHOTO 306 | version (lowercase only) 307 | 308 | =head2 more complex vCard nodes 309 | 310 | vCard Spec Alias Methods on object 311 | ---------- ---------- ----------------- 312 | N name (depreciated as conflicts with rfc, use moniker) 313 | N moniker 'family','given','middle','prefixes','suffixes' 314 | ADR addresses 'po_box','extended','street','city','region','post_code','country','label' 315 | GEO 'lat','long' 316 | TEL phones 317 | LABELS 318 | ORG 'name','unit' (unit is a special case and will return an array reference) 319 | 320 | my $addresses = $vcard->get( { 'node_type' => 'addresses' } ); 321 | foreach my $address ( @{$addresses} ) { 322 | print $address->street(); 323 | } 324 | 325 | # Setting values on an address element 326 | $addresses->[0]->street('The burrows'); 327 | $addresses->[0]->region('Wimbeldon common'); 328 | 329 | # Checking an address is a specific type 330 | $addresses->[0]->is_type('fax'); 331 | $addresses->[0]->add_types('home'); 332 | $addresses->[0]->remove_types('work'); 333 | 334 | =head2 get_group() 335 | 336 | my $group_name = 'item1'; 337 | my $node_type = 'X-ABLABEL'; 338 | my $of_group = $vcard->get_group( $group_name, $node_type ); 339 | foreach my $label ( @{$of_group} ) { 340 | print $label->value(); 341 | } 342 | 343 | This method takes one or two arguments. The group name 344 | (accessable on any node object by using $node->group() - not 345 | all nodes will have a group, indeed most vcards do not seem 346 | to use it) and optionally the types of node you with to 347 | have returned. 348 | 349 | Either an array or array reference is returned depending 350 | on the calling context, if there are no matches it will 351 | be empty. 352 | 353 | =cut 354 | 355 | sub get_group { 356 | my ( $self, $group_name, $node_type ) = @_; 357 | my @to_return; 358 | 359 | carp "No group name supplied" 360 | unless defined $group_name 361 | and $group_name ne ''; 362 | 363 | $group_name = lc($group_name); 364 | 365 | if ( defined $node_type && $node_type ne '' ) { 366 | 367 | # After a specific node type 368 | my $nodes = $self->get($node_type); 369 | foreach my $node ( @{$nodes} ) { 370 | push( @to_return, $node ) if $node->group() eq $group_name; 371 | } 372 | } else { 373 | 374 | # We want everything from that group 375 | foreach my $node_loop ( keys %{ $self->{nodes} } ) { 376 | 377 | # Loop through each type 378 | my $nodes = $self->get($node_loop); 379 | foreach my $node ( @{$nodes} ) { 380 | if ( $node->group() ) { 381 | push( @to_return, $node ) 382 | if $node->group() eq $group_name; 383 | } 384 | } 385 | } 386 | } 387 | return wantarray ? @to_return : \@to_return; 388 | } 389 | 390 | =head1 BINARY METHODS 391 | 392 | These methods allow access to what are potentially binary values such 393 | as a photo or sound file. Binary values will be correctly encoded and 394 | decoded to/from base 64. 395 | 396 | API still to be finalised. 397 | 398 | =head2 photo() 399 | 400 | =head2 sound() 401 | 402 | =head2 key() 403 | 404 | =head2 logo() 405 | 406 | =cut 407 | 408 | sub DESTROY { 409 | } 410 | 411 | =head2 get_lookup 412 | 413 | This method is used internally to lookup those nodes which have 414 | multiple elements, e.g. GEO has lat and long, N (name) has family, 415 | given, middle etc. 416 | 417 | If you wish to extend this package (for custom attributes), overload 418 | this method in your code: 419 | 420 | sub my_lookup { 421 | return \%my_lookup; 422 | } 423 | *Text::vCard::get_lookup = \&my_lookup; 424 | 425 | This has not been tested yet. 426 | 427 | =cut 428 | 429 | sub get_lookup { 430 | my $self = shift; 431 | return \%lookup; 432 | } 433 | 434 | =head2 get_of_type() 435 | 436 | my $list = $vcard->get_of_type( $node_type, \@types ); 437 | 438 | It is probably easier just to use the get() method, which inturn calls 439 | this method. 440 | 441 | =cut 442 | 443 | # Used to get the right elements 444 | sub get_of_type { 445 | my ( $self, $node_type, $types ) = @_; 446 | 447 | # Upper case the name 448 | $node_type = uc($node_type); 449 | 450 | # See if there is an alias for it 451 | $node_type = uc( $node_aliases{$node_type} ) 452 | if defined $node_aliases{$node_type}; 453 | 454 | return undef unless defined $self->{nodes}->{$node_type}; 455 | 456 | if ($types) { 457 | 458 | # After specific types 459 | my @of_type; 460 | if ( ref($types) eq 'ARRAY' ) { 461 | @of_type = @{$types}; 462 | } else { 463 | push( @of_type, $types ); 464 | } 465 | my @to_return; 466 | foreach my $element ( @{ $self->{nodes}->{$node_type} } ) { 467 | my $check = 1; # assum ok for now 468 | foreach my $type (@of_type) { 469 | 470 | # set it as bad if we don't match 471 | $check = 0 unless $element->is_type($type); 472 | } 473 | if ( $check == 1 ) { 474 | 475 | push( @to_return, $element ); 476 | } 477 | } 478 | 479 | return undef unless scalar(@to_return); 480 | 481 | # Make prefered value first 482 | @to_return = sort { _sort_prefs($b) <=> _sort_prefs($a) } @to_return; 483 | 484 | return wantarray ? @to_return : \@to_return; 485 | 486 | } else { 487 | 488 | # Return them all 489 | return wantarray 490 | ? @{ $self->{nodes}->{$node_type} } 491 | : $self->{nodes}->{$node_type}; 492 | } 493 | } 494 | 495 | =head2 as_string 496 | 497 | Returns the vCard as a string. 498 | 499 | =cut 500 | 501 | sub as_string { 502 | my ( $self, $fields ) = @_; 503 | 504 | # derp 505 | my %e = map { lc $_ => 1 } @{ $fields || [] }; 506 | 507 | my @k = qw(VERSION N FN); 508 | if ($fields) { 509 | push @k, sort map { uc $_ } @$fields; 510 | } else { 511 | push @k, grep { $_ !~ /^(VERSION|N|FN)$/ } 512 | sort map { uc $_ } keys %{ $self->{nodes} }; 513 | } 514 | 515 | # 'perldoc perlport' says using \r\n is wrong and confusing for a few 516 | # reasons but mainly because the value of \n is different on different 517 | # operating systems. It recommends \x0D\x0A instead. 518 | my $newline = "\x0D\x0A"; 519 | my $begin = 'BEGIN:VCARD'; 520 | my $end = 'END:VCARD'; 521 | 522 | my @lines = ($begin); 523 | for my $k (@k) { 524 | my $nodes = $self->get($k); 525 | push @lines, map { $_->as_string() } @$nodes; 526 | } 527 | return join $newline, @lines, $end, ''; 528 | } 529 | 530 | sub _sort_prefs { 531 | my $check = shift; 532 | if ( $check->is_type('pref') ) { 533 | return 1; 534 | } else { 535 | return 0; 536 | } 537 | } 538 | 539 | # Private method for adding nodes 540 | sub _add_node { 541 | my ( $self, $conf ) = @_; 542 | 543 | my $value_fields = $self->get_lookup(); 544 | 545 | my $node_type = uc( $conf->{node_type} ); 546 | $node_type = $node_aliases{$node_type} 547 | if defined $node_aliases{$node_type}; 548 | 549 | my $field_list; 550 | 551 | if ( defined $value_fields->{$node_type} ) { 552 | 553 | # We know what the field list is 554 | $field_list = $value_fields->{$node_type}; 555 | } else { 556 | 557 | # No defined fields - use just the 'value' one 558 | $field_list = \@default_field; 559 | } 560 | unless ( defined $self->{nodes}->{$node_type} ) { 561 | 562 | # create space to hold list of node objects 563 | my @node_list_space; 564 | $self->{nodes}->{$node_type} = \@node_list_space; 565 | } 566 | my $last_node; 567 | foreach my $node_data ( @{ $conf->{data} } ) { 568 | my $node_obj = Text::vCard::Node->new( 569 | { node_type => $node_type, 570 | fields => $field_list, 571 | data => $node_data, 572 | group => $conf->{group} || '', 573 | encoding_out => $self->{encoding_out}, 574 | } 575 | ); 576 | 577 | push( @{ $self->{nodes}->{$node_type} }, $node_obj ); 578 | 579 | # store the last node so we can return it. 580 | $last_node = $node_obj; 581 | } 582 | return $last_node; 583 | } 584 | 585 | =head1 AUTHOR 586 | 587 | Leo Lapworth, LLAP@cuckoo.org 588 | Eric Johnson (kablamo), github ~!at!~ iijo dot org 589 | 590 | =head1 Repository (git) 591 | 592 | http://github.com/ranguard/text-vcard, git://github.com/ranguard/text-vcard.git 593 | 594 | =head1 COPYRIGHT 595 | 596 | Copyright (c) 2005-2010 Leo Lapworth. All rights reserved. 597 | This program is free software; you can redistribute 598 | it and/or modify it under the same terms as Perl itself. 599 | 600 | =head1 SEE ALSO 601 | 602 | L, L, 603 | L L, L L, 604 | 605 | =cut 606 | 607 | 1; 608 | -------------------------------------------------------------------------------- /lib/Text/vCard/Node.pm: -------------------------------------------------------------------------------- 1 | package Text::vCard::Node; 2 | 3 | use strict; 4 | use warnings; 5 | use Carp; 6 | use Encode; 7 | use MIME::Base64 3.07; 8 | use MIME::QuotedPrint 3.07; 9 | use Unicode::LineBreak; 10 | use Text::Wrap; 11 | use vars qw ( $AUTOLOAD ); 12 | 13 | =head1 NAME 14 | 15 | Text::vCard::Node - Object for each node (line) of a vCard 16 | 17 | =head1 SYNOPSIS 18 | 19 | use Text::vCard::Node; 20 | 21 | my %data = ( 22 | 'param' => { 23 | 'HOME,PREF' => 'undef', 24 | }, 25 | 'value' => ';;First work address - street;Work city;London;Work PostCode;CountryName', 26 | ); 27 | 28 | my $node = Text::vCard::Node->new({ 29 | node_type => 'address', # Auto upper cased 30 | fields => ['po_box','extended','street','city','region','post_code','country'], 31 | data => \%data, 32 | }); 33 | 34 | =head1 DESCRIPTION 35 | 36 | Package used by Text::vCard so that each element: ADR, N, TEL etc are objects. 37 | 38 | You should not need to use this module directly, L does it all for you. 39 | 40 | =head1 METHODS 41 | 42 | =head2 new() 43 | 44 | my $node = Text::vCard::Node->new({ 45 | node_type => 'address', # Auto upper cased 46 | fields => \['po_box','extended','street','city','region','post_code','country'], 47 | data => \%data, 48 | }); 49 | 50 | =head2 value() 51 | 52 | # Get the value for a standard single value node 53 | my $value = $node->value(); 54 | 55 | # Or set the value 56 | $node->value('New value'); 57 | 58 | =head2 other()'s 59 | 60 | # The fields supplied in the conf area also methods. 61 | my $po_box = $node->po_box(); # if the node was an ADR. 62 | 63 | # Set the value. 64 | my $street = $node->street('73 Sesame Street'); 65 | 66 | =cut 67 | 68 | sub new { 69 | my ( $proto, $conf ) = @_; 70 | my $class = ref($proto) || $proto; 71 | my $self = {}; 72 | carp "No fields defined" unless defined $conf->{'fields'}; 73 | carp "fields is not an array ref" 74 | unless ref( $conf->{'fields'} ) eq 'ARRAY'; 75 | 76 | bless( $self, $class ); 77 | 78 | $self->{encoding_out} = $conf->{encoding_out} || 'UTF-8'; 79 | 80 | $self->{node_type} = uc( $conf->{node_type} ) 81 | if defined $conf->{node_type}; 82 | $self->group( $conf->{group} ) if defined $conf->{group}; 83 | 84 | # Store the field order. 85 | $self->{'field_order'} = $conf->{'fields'}; 86 | 87 | # store the actual field names so we can look them up 88 | my %fields; 89 | map { $fields{$_} = 1 } @{ $self->{'field_order'} }; 90 | $self->{'field_lookup'} = \%fields; 91 | 92 | if ( defined $conf->{'data'} ) { 93 | 94 | # Populate now, rather than later (via AUTOLOAD) 95 | # store values into object 96 | if ( defined $conf->{'data'}->{'params'} ) { 97 | my %params; 98 | 99 | # Loop through array 100 | foreach my $param_hash ( @{ $conf->{'data'}->{'params'} } ) { 101 | while ( my ( $key, $value ) = each %{$param_hash} ) { 102 | my $t = 'type'; 103 | 104 | # go through each key/value pair 105 | my $param_list = $key; 106 | if ( defined $value ) { 107 | $t = $key; 108 | 109 | # use value, not key as its 'type' => 'CELL', 110 | # not 'CELL' => undef 111 | $param_list = $value; 112 | } 113 | 114 | # These values might as well be useful for 115 | # something. Also get rid of any whitespace 116 | # pollution. 117 | for my $p ( split /\s*,\s*/, $param_list ) { 118 | $p =~ s/^\s*(.*?)\s*$/\L$1/; 119 | $p =~ s/\s+/ /g; 120 | $params{$p} = lc $t; 121 | } 122 | } 123 | } 124 | $self->{params} = \%params; 125 | } 126 | 127 | if ( defined $conf->{'data'}->{'value'} ) { 128 | 129 | # Store the actual data into the object 130 | 131 | if ( $self->is_type('q') or $self->is_type('quoted-printable') ) { 132 | 133 | my $value = $conf->{data}{value}; 134 | my $mime_decoded = MIME::QuotedPrint::decode($value); 135 | my $encode_decoded = Encode::decode( 'UTF-8', $mime_decoded ); 136 | my $unescaped = $self->_unescape($encode_decoded); 137 | $conf->{'data'}->{'value'} = $unescaped; 138 | } 139 | 140 | if ( $self->is_type('b') or $self->is_type('base64') ) { 141 | 142 | # Don't Encode::decode() $mime_decoded because it is usually 143 | # (99% of the time) a binary value like a photo and not a 144 | # string. 145 | # 146 | # Also do not escape binary values. 147 | 148 | my $value = $conf->{data}{value}; 149 | my $mime_decoded = MIME::Base64::decode($value); 150 | $conf->{data}{value} = $mime_decoded; 151 | 152 | # mimic what goes on below 153 | @{$self}{ @{ $self->{field_order} } } 154 | = ( $conf->{data}{value} ); 155 | } else { 156 | 157 | # the -1 on split is so ;; values create elements in 158 | # the array 159 | my @elements = split /(?{data}{value}, -1; 160 | if ( defined $self->{node_type} 161 | && $self->{node_type} eq 'ORG' ) 162 | { 163 | my @unescaped = $self->_unescape_list(@elements); 164 | 165 | $self->{'name'} = shift(@unescaped); 166 | $self->{'unit'} = \@unescaped if scalar(@unescaped) > 0; 167 | } 168 | 169 | # no need for explicit scalar 170 | elsif ( @elements <= @{ $self->{field_order} } ) { 171 | my @unescaped = $self->_unescape_list(@elements); 172 | 173 | # set the field values as the data 174 | # e.g. $self->{street} = 'The street' 175 | @{$self}{ @{ $self->{field_order} } } = @unescaped; 176 | } else { 177 | carp sprintf( 178 | 'Data value had %d elements expecting %d or less.', 179 | scalar @elements, 180 | scalar @{ $self->{field_order} } 181 | ); 182 | } 183 | } 184 | } 185 | } 186 | return $self; 187 | } 188 | 189 | sub _unescape { 190 | my ( $self, $value ) = @_; 191 | $value =~ s|\\([\\,;])|$1|g; 192 | return $value; 193 | } 194 | 195 | sub _unescape_list { 196 | my ( $self, @values ) = @_; 197 | return map { $self->_unescape($_) } @values; 198 | } 199 | 200 | =head2 node_type 201 | 202 | Returns the type of the node itself, e.g. ADR. 203 | 204 | =cut 205 | 206 | sub node_type { 207 | $_[0]->{node_type}; 208 | } 209 | 210 | =head2 unit() 211 | 212 | my @units = @{ $org_node->unit() }; 213 | $org_node->unit( [ 'Division', 'Department', 'Sub-department' ] ); 214 | 215 | As ORG allows unlimited numbers of 'units' as well as and organisation 216 | 'name', this method is a specific case for accessing those values, they 217 | are always returned as an array reference, and should always be set 218 | as an array reference. 219 | 220 | =cut 221 | 222 | sub unit { 223 | my ( $self, $val ) = @_; 224 | $self->{'unit'} = $val if $val && ref($val) eq 'ARRAY'; 225 | return $self->{'unit'} if defined $self->{'unit'}; 226 | return undef; 227 | } 228 | 229 | =head2 types() 230 | 231 | my @types = $node->types(); 232 | 233 | # or 234 | my $types = $node->types(); 235 | 236 | This method will return an array or an array ref depending 237 | on the calling context of types associated with the $node, 238 | undef is returned if there are no types. 239 | 240 | All types returned are lower case. 241 | 242 | =cut 243 | 244 | sub types { 245 | my $self = shift; 246 | my @types; 247 | return undef unless defined $self->{params}; 248 | foreach my $key ( sort keys %{ $self->{params} } ) { 249 | my $value = $self->{params}->{$key}; 250 | push @types, lc $key if $value && $value eq 'type'; 251 | } 252 | return wantarray ? @types : \@types; 253 | } 254 | 255 | =head2 is_type() 256 | 257 | if ( $node->is_type($type) ) { 258 | 259 | # ... 260 | } 261 | 262 | Given a type (see types() for a list of those set) 263 | this method returns 1 if the $node is of that type 264 | or undef if it is not. 265 | 266 | =cut 267 | 268 | sub is_type { 269 | my ( $self, $type ) = @_; 270 | if ( defined $self->{params} && exists $self->{params}->{ lc($type) } ) { 271 | 272 | # Make this always return true so as not to change the net 273 | # behaviour of the method. if for some wack (and 274 | # non-compliant) reason this value is undef, empty string or 275 | # zero, tough luck. 276 | return $self->{params}{ lc $type } || 1; 277 | } 278 | return undef; 279 | } 280 | 281 | =head2 is_pref(); 282 | 283 | if ( $node->is_pref() ) { 284 | print "Preferred node"; 285 | } 286 | 287 | This method is the same as is_type (which can take a value of 'pref') 288 | but it specific to if it is the preferred node. This method is used 289 | to sort when returning lists of nodes. 290 | 291 | =cut 292 | 293 | # A preferred node can be indicated in a vcard file 2 ways: 294 | # 295 | # 1. As 'PREF=1' which makes $self->{params} look like: 296 | # { 1 => 'pref', work => 'type' } 297 | # 298 | # 2. As 'TYPE=PREF' which makes $self->{params} look like: 299 | # { pref => 'type', work => 'type' } 300 | # 301 | sub is_pref { 302 | my $self = shift; 303 | my $params = $self->{params}; 304 | if (( defined $params ) && # 305 | ( defined $params->{1} && $params->{1} eq 'pref' ) || # 306 | ( defined $params->{pref} ) 307 | ) 308 | { 309 | return 1; 310 | } 311 | return undef; 312 | } 313 | 314 | =head2 add_types() 315 | 316 | $address->add_types('home'); 317 | 318 | my @types = qw(home work); 319 | $address->add_types( \@types ); 320 | 321 | Add a type to an address, it can take a scalar or an array ref. 322 | 323 | =cut 324 | 325 | sub add_types { 326 | my ( $self, $type ) = @_; 327 | unless ( defined $self->{params} ) { 328 | 329 | # no params, create a hash ref in there 330 | my %params; 331 | $self->{params} = \%params; 332 | } 333 | if ( ref($type) eq 'ARRAY' ) { 334 | map { $self->{params}->{ lc($_) } = 'type' } @{$type}; 335 | } else { 336 | $self->{params}->{ lc($type) } = 'type'; 337 | } 338 | } 339 | 340 | =head2 remove_types() 341 | 342 | $address->remove_types('home'); 343 | 344 | my @types = qw(home work); 345 | $address->remove_types( \@types ); 346 | 347 | This method removes a type from an address, it can take a scalar 348 | or an array ref. 349 | 350 | undef is returned when in scalar context and the type does not match, 351 | or when in array ref context and none of the types match, true is 352 | returned otherwise. 353 | 354 | =cut 355 | 356 | sub remove_types { 357 | my ( $self, $type ) = @_; 358 | return undef unless defined $self->{params}; 359 | 360 | if ( ref($type) eq 'ARRAY' ) { 361 | my $to_return = undef; 362 | foreach my $t ( @{$type} ) { 363 | if ( exists $self->{params}->{ lc($t) } ) { 364 | delete $self->{params}->{ lc($t) }; 365 | $to_return = 1; 366 | } 367 | } 368 | return $to_return; 369 | } else { 370 | if ( exists $self->{params}->{ lc($type) } ) { 371 | delete $self->{params}->{ lc($type) }; 372 | return 1; 373 | } 374 | } 375 | return undef; 376 | } 377 | 378 | =head2 group() 379 | 380 | my $group = $node->group(); 381 | 382 | If called without any arguments, this method returns the group 383 | name if a node belongs to a group. Otherwise undef is returned. 384 | 385 | If an argument is supplied then this is set as the group name. 386 | 387 | All group names are always lowercased. 388 | 389 | For example, Apple Address book used 'itemN' to group it's 390 | custom X-AB... nodes with a TEL or ADR node. 391 | 392 | =cut 393 | 394 | sub group { 395 | my $self = shift; 396 | if ( my $val = shift ) { 397 | $self->{group} = lc($val); 398 | } 399 | return $self->{group} if defined $self->{group}; 400 | return undef; 401 | } 402 | 403 | =head2 export_data() 404 | 405 | NOTE: This method is deprecated and should not be used. It will be removed in 406 | a later version. 407 | 408 | my $value = $node->export_data(); 409 | 410 | This method returns the value string of a node. 411 | It is only needs to be called when exporting the information 412 | back out to ensure that it has not been altered. 413 | 414 | =cut 415 | 416 | sub export_data { 417 | my $self = shift; 418 | my @lines = map { 419 | if ( defined $self->{$_} ) { 420 | if ( ref( $self->{$_} ) eq 'ARRAY' ) { 421 | 422 | # Handle things like org etc which have 'units' 423 | join( ',', @{ $self->{$_} } ); 424 | } else { 425 | $self->{$_}; 426 | } 427 | } else { 428 | ''; 429 | } 430 | } @{ $self->{'field_order'} }; 431 | 432 | # Should escape stuff here really, but waiting to see what 433 | # T::vfile::asData does 434 | return join( ';', @lines ); 435 | 436 | } 437 | 438 | =head2 as_string 439 | 440 | Returns the node as a formatted string. 441 | 442 | =cut 443 | 444 | sub _key_as_string { 445 | my ($self) = @_; 446 | 447 | my $n = ''; 448 | $n .= $self->group . '.' if $self->group; 449 | $n .= $self->node_type; 450 | $n .= $self->_params if $self->_params; 451 | 452 | return $n; 453 | } 454 | 455 | # returns a string of params formatted for saving to a vcard file 456 | # returns false if there are no params 457 | sub _params { 458 | my ($self) = @_; 459 | 460 | my %t; 461 | for my $t ( sort keys %{ $self->{params} } ) { 462 | my $backwards = uc $self->is_type( lc $t ); 463 | $t{$backwards} ||= []; 464 | push @{ $t{$backwards} }, lc $t; 465 | } 466 | 467 | $t{CHARSET} = [ lc $self->{encoding_out} ] 468 | if $self->{encoding_out} ne 'none' 469 | && $self->{encoding_out} !~ /UTF-8/i 470 | && !$self->is_type('b') 471 | && !$self->is_type('base64'); 472 | 473 | my @params = map { sprintf( '%s=%s', $_, join ',', @{ $t{$_} } ) } # 474 | sort keys %t; 475 | 476 | return @params ? ';' . join( ';', @params ) : undef; 477 | } 478 | 479 | # The vCard RFC requires commas, semicolons, and backslashes to be escaped. 480 | # See http://tools.ietf.org/search/rfc6350#section-3.4 481 | # 482 | # Line breaks which are part of a value and are intended to be seen by humans 483 | # must have a value of '\n'. 484 | # See http://tools.ietf.org/search/rfc6350#section-4.1 485 | # 486 | # Line breaks which happen because the RFC requires a line break after 75 487 | # characters have a value of '\r\n'. These line breaks are not handled by 488 | # this method. See _newline() and 489 | # http://tools.ietf.org/search/rfc6350#section-3.2 490 | # 491 | # Don't escape anything if this is a base64 node. Escaping only applies to 492 | # strings not binary values. 493 | # 494 | # 'perldoc perlport' says using \r\n is wrong and confusing for a few reasons 495 | # but mainly because the value of \n is different on different operating 496 | # systems. It recommends \x0D\x0A instead. 497 | sub _escape { 498 | my ( $self, $val ) = @_; 499 | return $val if ( $self->is_type('b') or $self->is_type('base64') ); 500 | $val =~ s/(\x0D\x0A|\x0D|\x0A)/\x0A/g; 501 | $val =~ s/([,;|])/\\$1/g; 502 | return $val; 503 | } 504 | 505 | sub _escape_list { 506 | my ( $self, @list ) = @_; 507 | return map { $self->_escape($_) } @list; 508 | } 509 | 510 | # The vCard RFC says new lines must be \r\n 511 | # See http://tools.ietf.org/search/rfc6350#section-3.2 512 | # 513 | # 'perldoc perlport' says using \r\n is wrong and confusing for a few reasons 514 | # but mainly because the value of \n is different on different operating 515 | # systems. It recommends \x0D\x0A instead. 516 | sub _newline { 517 | my ($self) = @_; 518 | return "\x0D\x0A" if $self->{encoding_out} eq 'none'; 519 | return Encode::encode( $self->{encoding_out}, "\x0D\x0A" ); 520 | } 521 | 522 | sub _decode_string { 523 | my ( $self, $string ) = @_; 524 | return $string if $self->{encoding_out} eq 'none'; 525 | return Encode::decode( $self->{encoding_out}, $string ); 526 | } 527 | 528 | sub _encode_string { 529 | my ( $self, $string ) = @_; 530 | return $string if $self->{encoding_out} eq 'none'; 531 | return Encode::encode( $self->{encoding_out}, $string ); 532 | } 533 | 534 | sub _encode_list { 535 | my ( $self, @list ) = @_; 536 | return @list if $self->{encoding_out} eq 'none'; 537 | return map { $self->_encode_string($_) } @list; 538 | } 539 | 540 | # The vCard RFC says lines should be wrapped (or 'folded') at 75 octets 541 | # excluding the line break. The line is continued on the next line with a 542 | # space as the first character. See 543 | # http://tools.ietf.org/search/rfc6350#section-3.1 for details. 544 | # 545 | # Note than an octet is 1 byte (8 bits) and is not necessarily equal to 1 546 | # character, 1 grapheme, 1 codepoint, or 1 column of output. Actually none of 547 | # those things are necessarily equal. See 548 | # http://www.perl.com/pub/2012/05/perlunicook-string-length-in-graphemes.html 549 | # 550 | # MIME::QuotedPrint does line wrapping but it assumes the line length must be 551 | # <= 76 chars which doesn't work for us. 552 | # 553 | # Can't use Unicode::LineBreak because it wraps by counting characters and the 554 | # vCard spec wants us to wrap by counting octets. 555 | sub _wrap { 556 | my ( $self, $key, $value ) = @_; 557 | 558 | return $self->_wrap_naively( $key, $value ) 559 | unless $self->{encoding_out} =~ /UTF-8/i; 560 | 561 | if ( $self->is_type('q') or $self->is_type('quoted-printable') ) { 562 | ## See the Quoted-Printable RFC205 563 | ## https://tools.ietf.org/html/rfc2045#section-6.7 (rule 5) 564 | my $newline 565 | = $self->_encode_string("=") 566 | . $self->_newline 567 | . $self->_encode_string(" "); 568 | my $max 569 | = 73; # 75 octets per line max including '=' and ' ' from $newline 570 | return $self->_wrap_utf8( $key, $value, $max, $newline ); 571 | } 572 | 573 | my $newline = $self->_newline . $self->_encode_string(" "); 574 | my $max = 74; # 75 octets per line max including " " from $newline 575 | return $self->_wrap_utf8( $key, $value, $max, $newline ); 576 | } 577 | 578 | sub _wrap_utf8 { 579 | my ( $self, $key, $value, $max, $newline ) = @_; 580 | 581 | my $gcs = Unicode::GCString->new(Encode::decode('UTF-8', $key . $value)); 582 | return $key . $value if bytes::length( $gcs->as_string ) <= $max; 583 | 584 | my $start = 0; 585 | my @wrapped_lines; 586 | 587 | # first line is 1 character longer than the others because it doesn't 588 | # begin with a " " 589 | my $first_max = $max + 1; 590 | 591 | while ( $start <= $gcs->length ) { 592 | my $len = 1; 593 | 594 | while ( ( $start + $len ) <= $gcs->length ) { 595 | 596 | my $line = $gcs->substr( $start, $len ); 597 | my $bytes = bytes::length( $line->as_string ); 598 | 599 | # is this a good place to line wrap? 600 | if ( $first_max && $bytes <= $first_max ) { 601 | ## no its not a good place to line wrap 602 | ## this if statement is only hit on the first line wrap 603 | $len++; 604 | next; 605 | } 606 | if ( $bytes <= $max ) { 607 | ## no its not a good place to line wrap 608 | $len++; 609 | next; 610 | } 611 | 612 | # wrap the line here 613 | $line = $gcs->substr( $start, $len - 1 )->as_string; 614 | push @wrapped_lines, Encode::encode('UTF-8',$line); 615 | $start += $len - 1; 616 | last; 617 | } 618 | 619 | if ( ( $start + $len - 1 ) >= $gcs->length ) { 620 | my $line = $gcs->substr( $start, $len - 1 )->as_string; 621 | push @wrapped_lines, Encode::encode('UTF-8',$line); 622 | last; 623 | } 624 | 625 | $first_max = undef; 626 | } 627 | 628 | return join $newline, @wrapped_lines; 629 | } 630 | 631 | # This will fail to line wrap properly for wide characters. The problem 632 | # is it naively wraps lines by counting the number of characters but the vcard 633 | # spec wants us to wrap after 75 octets (bytes). However clever vCard readers 634 | # may be able to deal with this. 635 | sub _wrap_naively { 636 | my ( $self, $key, $value ) = @_; 637 | 638 | $Text::Wrap::columns = 75; # wrap after 75 chars 639 | $Text::Wrap::break = qr/[.]/; # allow lines breaks anywhere 640 | $Text::Wrap::separator = $self->_newline; # use encoded new lines 641 | 642 | my $first_prefix = $key; # this text is placed before first line 643 | my $prefix = " "; # this text is placed before all other lines 644 | return Text::Wrap::wrap( $first_prefix, $prefix, $value ); 645 | } 646 | 647 | sub _encode { 648 | my ( $self, $value ) = @_; 649 | 650 | if ( $self->is_type('q') or $self->is_type('quoted-printable') ) { 651 | 652 | # Encode with Encode::encode() 653 | my $encoded_value = $self->_encode_string($value); 654 | return MIME::QuotedPrint::encode( $encoded_value, '' ); 655 | 656 | } elsif ( $self->is_type('b') or $self->is_type('base64') ) { 657 | 658 | # Scenarios where MIME::Base64::encode() works: 659 | # - for binary data (photo) -- 99% of cases 660 | # - if $value is a string with wide characters and the user has 661 | # encoded it as UTF-8. 662 | # - if $value is a string with no wide characters 663 | # 664 | # Scenario where MIME::Base64::encode() will die: 665 | # - if $value is a string with wide characters and the user has not 666 | # encoded it as UTF-8. 667 | return MIME::Base64::encode( $value, '' ); 668 | 669 | } else { 670 | $value = $self->_encode_string($value); 671 | } 672 | 673 | return $value; 674 | } 675 | 676 | # This method does the following: 677 | # 1. Escape and concatenate values 678 | # 2. Encode::encode() values 679 | # 3. MIME encode() values 680 | # 4. wrap lines to 75 octets 681 | # 5. Encode::decode() value 682 | # 683 | # Assumes there is only one MIME::Quoted-Printable field for a node. 684 | # Assumes there is only one MIME::Base64 field for a node. 685 | # 686 | # If either of the above assumptions is false, line wrapping may be incorrect. 687 | # However clever vCard readers may still be able to read vCards with incorrect 688 | # line wrapping. 689 | sub as_string { 690 | my ($self) = @_; 691 | my $key = $self->_key_as_string(); 692 | 693 | # Build up $raw_value from field values 694 | my @field_values; 695 | my $field_names = $self->{field_order}; 696 | foreach my $field_name (@$field_names) { 697 | next unless defined( my $field_value = $self->{$field_name} ); 698 | 699 | # escape stuff 700 | $field_value = ref $field_value eq 'ARRAY' # 701 | ? join( ';', $self->_escape_list(@$field_value) ) 702 | : $self->_escape($field_value); 703 | 704 | push @field_values, $field_value; 705 | } 706 | my $raw_value = join ';', @field_values; 707 | 708 | # MIME::*::encode() value 709 | my $encoded = $self->_encode($raw_value); 710 | 711 | # Line wrap everything to 75 octets 712 | my $wrapped = $self->_wrap( $key . ":", $encoded ); 713 | 714 | # Decode everything 715 | return $self->_decode_string($wrapped); 716 | } 717 | 718 | # Because we have autoload 719 | sub DESTROY { 720 | } 721 | 722 | # creates methods for a node object based on the field_names in the config 723 | # hash of the node. 724 | 725 | sub AUTOLOAD { 726 | my $name = $AUTOLOAD; 727 | $name =~ s/.*://; 728 | 729 | carp "$name method which is not valid for this node" 730 | unless defined $_[0]->{field_lookup}->{$name}; 731 | 732 | if ( $_[1] ) { 733 | 734 | # set it 735 | $_[0]->{$name} = $_[1]; 736 | } 737 | 738 | # Return it 739 | return $_[0]->{$name}; 740 | } 741 | 742 | =head2 NOTES 743 | 744 | If a node has a param of 'quoted-printable' then the 745 | value is escaped (basically converting Hex return into \r\n 746 | as far as I can see). 747 | 748 | =head1 AUTHOR 749 | 750 | Leo Lapworth, LLAP@cuckoo.org 751 | Eric Johnson (kablamo), github ~!at!~ iijo dot org 752 | 753 | =head1 SEE ALSO 754 | 755 | L L, 756 | L L, 757 | L L, 758 | 759 | =cut 760 | 761 | 1; 762 | 763 | --------------------------------------------------------------------------------