File Coverage

lib/Text/vCard.pm

Criterion	Covered	Total	%
statement	158	161	98.1
branch	63	68	92.6
condition	22	28	78.5
subroutine	21	22	95.4
pod	8	8	100.0
total	272	287	94.7

package Text::vCard;
$Text::vCard::VERSION = '3.09';
use 5.006;
use Carp;
use strict;
use warnings;
use Text::vFile::asData 0.07;
use Text::vCard::Node;

# See this module for your basic parser functions
use base qw(Text::vFile::asData);
use vars qw (%lookup %node_aliases @simple);

# If the node's data does not break down use this
my @default_field = qw(value);

# If it does use these
%lookup = (
    'ADR' => [
        'po_box', 'extended',  'street', 'city',
        'region', 'post_code', 'country'
    ],
    'N'   => [ 'family', 'given', 'middle', 'prefixes', 'suffixes' ],
    'GEO' => [ 'lat',    'long' ],
    'ORG' => [ 'name',   'unit' ],
);

%node_aliases = (
    'FULLNAME'  => 'FN',
    'BIRTHDAY'  => 'BDAY',
    'TIMEZONE'  => 'TZ',
    'PHONES'    => 'TEL',
    'ADDRESSES' => 'ADR',
    'NAME'      => 'N',      # To be deprecated as clashes with RFC
    'MONIKER'   => 'N',
);

# Generate all our simple methods
@simple
    = qw(FN BDAY MAILER TZ TITLE ROLE NOTE PRODID REV SORT-STRING UID URL CLASS FULLNAME BIRTHDAY TIMEZONE NAME EMAIL NICKNAME PHOTO);

# Now we want lowercase as well
map { push( @simple, lc($_) ) } @simple;

# Generate the methods
{
    no strict 'refs';
    no warnings 'redefine';

    # 'version' handled separately
    # to prevent conflict with ExtUtils::MakeMaker
    # and $VERSION
    for my $node ( @simple, "version" ) {
        *$node = sub {
            my ( $self, $value ) = @_;

            # See if we have it already
            my $nodes = $self->get($node);
            if ( !defined $nodes && $value ) {

                # Add it as a node if not exists and there is a value
                $self->add_node( { 'node_type' => $node, } );

                # Get it out again
                $nodes = $self->get($node);
            }

            if ( scalar($nodes) && $value ) {

                # Set it
                $nodes->[0]->value($value);
            }

            return $nodes->[0]->value() if scalar($nodes);
            return undef;
            }
    }
}

=head1 NAME

Text::vCard - Edit and create vCards (RFC 2426)

=head1 WARNING

L and L are built on top of this module and provide
a more intuitive user interface.  Please try those modules first.

=head1 SYNOPSIS

  use Text::vCard;
  my $cards
      = Text::vCard->new( { 'asData_node' => $objects_node_from_asData, } );

=head1 DESCRIPTION

A vCard is an electronic business card.

This package is for a single vCard (person / record / set of address
information). It provides an API to editing and creating vCards, or supplied
a specific piece of the Text::vFile::asData results it generates a vCard
with that content.

You should really use L as this handles creating
vCards from an existing file for you.

=head1 METHODS

=head2 new()

  use Text::vCard;

  my $new_vcard = Text::vCard->new();

  my $existing_vcard
      = Text::vCard->new( { 'asData_node' => $objects_node_from_asData, } );

=cut

sub new {
    my ( $proto, $conf ) = @_;
    my $class = ref($proto) || $proto;
    my $self = {};

    bless( $self, $class );

    $self->{encoding_out} = $conf->{encoding_out} || 'UTF-8';

    my %nodes;
    $self->{nodes} = \%nodes;

    if ( defined $conf->{'asData_node'} ) {

        # Have a vcard data node being passed in
        while ( my ( $node_type, $data ) = each %{ $conf->{'asData_node'} } )
        {
            my $group;
            if ( $node_type =~ /\./ ) {

                # Version 3.0 supports group types, we do not
                # so remove everything before '.'
                ( $group, $node_type ) = $node_type =~ /(.+)\.(.*)/;
            }

            # Deal with each type (ADR, FN, TEL etc)
            $self->_add_node(
                {   'node_type' => $node_type,
                    'data'      => $data,
                    'group'     => $group,
                }
            );
        }
    }    # else we're creating a new vCard

    return $self;
}

=head2 add_node()

  my $address = $vcard->add_node( { 'node_type' => 'ADR', } );

This creates a new address (a L object) in the vCard
which you can then call the address methods on. See below for what options are available.

The node_type parameter must conform to the vCard spec format (e.g. ADR not address)

=cut

sub add_node {
    my ( $self, $conf ) = @_;
    croak 'Must supply a node_type'
        unless defined $conf && defined $conf->{'node_type'};
    unless ( defined $conf->{data} ) {
        my %empty;
        my @data = ( \%empty );
        $conf->{'data'} = \@data;
    }

    $self->_add_node($conf);
}

=head2 get()

The following method allows you to extract the contents from the vCard.

  # get all elements
  $nodes = $vcard->get('tel');

  # Just get the home address
  my $nodes = $vcard->get(
      {   'node_type' => 'addresses',
          'types'     => 'home',
      }
  );

  # get all phone number that matches serveral types
  my @types = qw(work home);
  my $nodes = $vcard->get(
      {   'node_type' => 'tel',
          'types'     => \@types,
      }
  );


Either an array or array ref is returned, containing
L objects.  If there are no results of 'node_type'
undef is returned.

Supplied with a scalar or an array ref the methods
return a list of nodes of a type, where relevant. If any
of the elements is the prefered element it will be
returned as the first element of the list.

=cut

sub get {
    my ( $self, $conf ) = @_;
    carp "You did not supply an element type" unless defined $conf;
    if ( ref($conf) eq 'HASH' ) {
        return $self->get_of_type( $conf->{'node_type'}, $conf->{'types'} )
            if defined $conf->{'types'};
        return $self->get_of_type( $conf->{'node_type'} );
    } else {
        return $self->get_of_type($conf);
    }
}

=head2 get_simple_type()

The following method is a convenience wrapper for accessing simple elements.

  $value = $vcard->get_simple_type( 'email', [ 'internet', 'work' ] );

If multiple elements match, then only the first is returned.  If the object
isn't found, or doesn't have a simple value, then undef is returned.

The argument type may be ommitted, it can be a scalar, or it can be an
array reference if multiple types are selected.

=cut

sub get_simple_type {
    my ( $self, $node_type, $types ) = @_;
    carp "You did not supply an element type" unless defined $node_type;

    my %hash = ( 'node_type', $node_type );
    $hash{'types'} = $types if defined $types;
    my $node = $self->get( \%hash );
    return undef unless $node && @{$node} > 0 && exists $node->[0]->{'value'};

    $node->[0]->{'value'};
}

=head2 nodes

  my $addresses = $vcard->get( { 'node_type' => 'address' } );

  my $first_address = $addresses->[0];

  # get the value
  print $first_address->street();

  # set the value
  $first_address->street('Barney Rubble');

  # See if it is part of a group
  if ( $first_address->group() ) {
      print 'Group: ' . $first_address->group();
  }

According to the RFC the following 'simple' nodes should only have one
element, this is not enforced by this module, so for example you can
have multiple URL's if you wish.

=head2 simple nodes

For simple nodes, you can also access the first node in the following way:

  my $fn = $vcard->fullname();
  # or setting
  $vcard->fullname('new name');

The node will be automatically created if it does not exist and you
supplied a value.  undef is returned if the node does not
exist. Simple nodes can be called as all upper or all lowercase method
names.

  vCard Spec: 'simple'    Alias
  --------------------    --------
  FN                      fullname
  BDAY                    birthday
  MAILER
  TZ                      timezone
  TITLE
  ROLE
  NOTE
  PRODID
  REV
  SORT-STRING
  UID
  URL
  CLASS
  EMAIL
  NICKNAME
  PHOTO
  version (lowercase only)

=head2 more complex vCard nodes

  vCard Spec    Alias           Methods on object
  ----------    ----------      -----------------
  N             name (depreciated as conflicts with rfc, use moniker)
  N             moniker            'family','given','middle','prefixes','suffixes'
  ADR           addresses       'po_box','extended','street','city','region','post_code','country'
  GEO                           'lat','long'
  TEL           phones
  LABELS
  ORG                           'name','unit' (unit is a special case and will return an array reference)

  my $addresses = $vcard->get( { 'node_type' => 'addresses' } );
  foreach my $address ( @{$addresses} ) {
      print $address->street();
  }

  # Setting values on an address element
  $addresses->[0]->street('The burrows');
  $addresses->[0]->region('Wimbeldon common');

  # Checking an address is a specific type
  $addresses->[0]->is_type('fax');
  $addresses->[0]->add_types('home');
  $addresses->[0]->remove_types('work');

=head2 get_group()

  my $group_name = 'item1';
  my $node_type  = 'X-ABLABEL';
  my $of_group   = $vcard->get_group( $group_name, $node_type );
  foreach my $label ( @{$of_group} ) {
      print $label->value();
  }

This method takes one or two arguments. The group name
(accessable on any node object by using $node->group() - not
all nodes will have a group, indeed most vcards do not seem
to use it) and optionally the types of node you with to
have returned.

Either an array or array reference is returned depending
on the calling context, if there are no matches it will
be empty.

=cut

sub get_group {
    my ( $self, $group_name, $node_type ) = @_;
    my @to_return;

    carp "No group name supplied"
        unless defined $group_name
        and $group_name ne '';

    $group_name = lc($group_name);

    if ( defined $node_type && $node_type ne '' ) {

        # After a specific node type
        my $nodes = $self->get($node_type);
        foreach my $node ( @{$nodes} ) {
            push( @to_return, $node ) if $node->group() eq $group_name;
        }
    } else {

        # We want everything from that group
        foreach my $node_loop ( keys %{ $self->{nodes} } ) {

            # Loop through each type
            my $nodes = $self->get($node_loop);
            foreach my $node ( @{$nodes} ) {
                if ( $node->group() ) {
                    push( @to_return, $node )
                        if $node->group() eq $group_name;
                }
            }
        }
    }
    return wantarray ? @to_return : \@to_return;
}

=head1 BINARY METHODS

These methods allow access to what are potentially binary values such
as a photo or sound file. Binary values will be correctly encoded and
decoded to/from base 64.

API still to be finalised.

=head2 photo()

=head2 sound()

=head2 key()

=head2 logo()

=cut

sub DESTROY {
}

=head2 get_lookup

This method is used internally to lookup those nodes which have
multiple elements, e.g. GEO has lat and long, N (name) has family,
given, middle etc.

If you wish to extend this package (for custom attributes), overload
this method in your code:

  sub my_lookup {
      return \%my_lookup;
  }
  *Text::vCard::get_lookup = \&my_lookup;

This has not been tested yet.

=cut

sub get_lookup {
    my $self = shift;
    return \%lookup;
}

=head2 get_of_type()

  my $list = $vcard->get_of_type( $node_type, \@types );

It is probably easier just to use the get() method, which inturn calls
this method.

=cut

# Used to get the right elements
sub get_of_type {
    my ( $self, $node_type, $types ) = @_;

    # Upper case the name
    $node_type = uc($node_type);

    # See if there is an alias for it
    $node_type = uc( $node_aliases{$node_type} )
        if defined $node_aliases{$node_type};

    return undef unless defined $self->{nodes}->{$node_type};

    if ($types) {

        # After specific types
        my @of_type;
        if ( ref($types) eq 'ARRAY' ) {
            @of_type = @{$types};
        } else {
            push( @of_type, $types );
        }
        my @to_return;
        foreach my $element ( @{ $self->{nodes}->{$node_type} } ) {
            my $check = 1;    # assum ok for now
            foreach my $type (@of_type) {

                # set it as bad if we don't match
                $check = 0 unless $element->is_type($type);
            }
            if ( $check == 1 ) {

                push( @to_return, $element );
            }
        }

        return undef unless scalar(@to_return);

        # Make prefered value first
        @to_return = sort { _sort_prefs($b) <=> _sort_prefs($a) } @to_return;

        return wantarray ? @to_return : \@to_return;

    } else {

        # Return them all
        return wantarray
            ? @{ $self->{nodes}->{$node_type} }
            : $self->{nodes}->{$node_type};
    }
}

=head2 as_string

Returns the vCard as a string.

=cut

sub as_string {
    my ( $self, $fields ) = @_;

    # derp
    my %e = map { lc $_ => 1 } @{ $fields || [] };

    my @k = qw(VERSION N FN);
    if ($fields) {
        push @k, sort map { uc $_ } @$fields;
    } else {
        push @k, grep { $_ !~ /^(VERSION|N|FN)$/ }
            sort map { uc $_ } keys %{ $self->{nodes} };
    }

    # 'perldoc perlport' says using \r\n is wrong and confusing for a few
    # reasons but mainly because the value of \n is different on different
    # operating systems.  It recommends \x0D\x0A instead.
    my $newline = "\x0D\x0A";
    my $begin   = 'BEGIN:VCARD';
    my $end     = 'END:VCARD';

    my @lines = ($begin);
    for my $k (@k) {
        my $nodes = $self->get($k);
        push @lines, map { $_->as_string() } @$nodes;
    }
    return join $newline, @lines, $end, '';
}

sub _sort_prefs {
    my $check = shift;
    if ( $check->is_type('pref') ) {
        return 1;
    } else {
        return 0;
    }
}

# Private method for adding nodes
sub _add_node {
    my ( $self, $conf ) = @_;

    my $value_fields = $self->get_lookup();

    my $node_type = uc( $conf->{node_type} );
    $node_type = $node_aliases{$node_type}
        if defined $node_aliases{$node_type};

    my $field_list;

    if ( defined $value_fields->{$node_type} ) {

        # We know what the field list is
        $field_list = $value_fields->{$node_type};
    } else {

        # No defined fields - use just the 'value' one
        $field_list = \@default_field;
    }
    unless ( defined $self->{nodes}->{$node_type} ) {

        # create space to hold list of node objects
        my @node_list_space;
        $self->{nodes}->{$node_type} = \@node_list_space;
    }
    my $last_node;
    foreach my $node_data ( @{ $conf->{data} } ) {
        my $node_obj = Text::vCard::Node->new(
            {   node_type    => $node_type,
                fields       => $field_list,
                data         => $node_data,
                group        => $conf->{group} || '',
                encoding_out => $self->{encoding_out},
            }
        );

        push( @{ $self->{nodes}->{$node_type} }, $node_obj );

        # store the last node so we can return it.
        $last_node = $node_obj;
    }
    return $last_node;
}

=head1 AUTHOR

Leo Lapworth, [e-mail]
Eric Johnson (kablamo), github ~!at!~ iijo dot org

=head1 Repository (git)

http://github.com/ranguard/text-vcard, git://github.com/ranguard/text-vcard.git

=head1 COPYRIGHT

Copyright (c) 2005-2010 Leo Lapworth. All rights reserved.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

L, L,
L L, L L,

=cut

1;