File Coverage

blib/lib/Text/SimpleVcard.pm

Criterion	Covered	Total	%
statement	105	117	89.7
branch	21	32	65.6
condition	2	6	33.3
subroutine	15	17	88.2
pod	6	7	85.7
total	149	179	83.2

# ===========================================================================
# Text::SimpleVproperty - a package to manage a single vCard-property
# ===========================================================================
package Text::SimpleVproperty;

use warnings;
use strict;

use MIME::QuotedPrint();

# ---------------------------------------------------------------------------
# Check if a value is element of an array
# ---------------------------------------------------------------------------
sub isIn {
   my $val = shift;
   return( scalar grep( /^$val$/, @_) > 0);
}

sub new {
   my( $class, $data) = @_;
   my $self = {};
   my $enc = "";

   my ( $meta, $val) = ( $data =~ /(.*?):(.*)/);
   my @meta = split( /;/, $meta);
   $self->{ name} = uc( shift( @meta));

   foreach( @meta){
      my( $key, $val) = ( "TYPE", $_);

      if( $val =~ /=/) {
         ( $key, $val) = split( /\s*=\s*/);
      }
      if( $key eq "ENCODING") {
	 $enc = $val;
	 next;
      }

      if( $key =~ /TYPE/i) {
	 push( @{$self->{ types}}, $val) if( !isIn( $val, @{$self->{ types}}));
      } else {
	 ${ $self->{ param}}{ $key} = $val;
      }
   }
   if( $enc eq "QUOTED-PRINTABLE") {
      $self->{ val} = MIME::QuotedPrint::decode_qp( $val);
   } else {
      $self->{ val} = $val;
   }

   bless( $self, $class);
}

sub hasType {
   my( $class, $typ) = @_;

   return isIn( uc( $typ), @{ $class->{ types}});
}

sub sprint {
   my( $class) = @_;
   my $res = "$class->{ name}";

   foreach( @{ $class->{ types}}) {
      $res .= ";TYPE=$_";
   }
   foreach( keys %{ $class->{ param}}) {
      my $val = ${ $class->{ param}}{ $_};
      $res .= ";$_" . ( defined( $val) ? "=$val" : "");
   }
   $res .= ":$class->{ val}";
   return $res;
}

sub print {
   my( $class, $hdr) = @_;

   print $hdr if( $hdr);
   print $class->sprint() . "\n";
}

# ===========================================================================
# Text::SimpleVcard - a package to manage a single vCard
# ===========================================================================
package Text::SimpleVcard;

use warnings;
use strict;

=head1 NAME

Text::SimpleVcard - a package to manage a single vCard

=head1 VERSION

Version 0.05

=cut

our $VERSION = '0.05';

=head1 SYNOPSIS

simplevCard - This package provides an API to reading a single vCard. A vCard is an
electronic business card. You will find that many applications (KDE Address book,
Apple Address book, MS Outlook, Evolution, etc.) use and can export and import vCards.

This module offers only basic vcard features (folding, ...). Grouping, etc. is not yet
supported. Further enhancements are always welcome.

SimpleVcard has a minimum of dependencies (actually only 'MIME::QuotedPrint'), it
should work with every installation.

   use Text::SimpleVcard;

   open FH, "< std.vcf";        # 'std.vcf' contains a single vcard-entry
   my $vCard = Text::SimpleVcard->new( join( '', ));
   $vCard->print();
   print "FN=" . $vCard->getSimpleValue( 'FN') . "\n";
   print "fullname=" . $vCard->getFullName() . "\n";
   my %h = $vCard->getValuesAsHash( 'TEL', [qw( WORK HOME)]);

   print "phone-numbers are:\n";
   foreach( keys %h) {
      print "Got number $_ ($h{$_})\n";
   }

=head1 FUNCTIONS

=head2 new()

   my $vCard = simpleVcard->new( $dat);

The method will create a C object from vcard data (e.g. from
a vCard-File (see example above)). Nested vCards will be ignored.

=cut

sub new {
   my( $class, $data) = @_;
   my $self = {};

   $data =~ s/[\r\n]+ +//gm;            # lines starting with space belong to last line (unfolding)
   my @data = split( /[\r\n]+/, $data);
   my( $fl, $ll) = ( shift( @data), pop( @data));	# chop enclosing BEGIN-, END-lines

   if( $fl ne "BEGIN:VCARD" and $ll ne "END:VCARD") {	# check if they are syntactically correct
      warn "vcard should begin with VCARD:BEGIN and end with VCARD:END";
      return;
   }

   my $vCardCnt = 0;
   foreach( @data) {
      $vCardCnt++ if( /^BEGIN:VCARD/);          #
      $vCardCnt-- if( /^END:VCARD/);            # skip nested vcards
      next if( $vCardCnt != 0 or /^END:VCARD/); #
      my $p = Text::SimpleVproperty->new( $_);  # push new property on the array behind the ...
      push( @{ $self->{ $p->{ name}}}, $p);     # ... hash-value of the key with the property-name
   }
   bless( $self, $class);
}

=head2 print()

   $vCard->print();
   $vCard->sprint();

The method will print a C-object to stdout or, in case of C to a string

=cut

sub sprint {
   my( $class) = @_;
   my $res = '';

   foreach my $propKey ( keys %$class) {
      foreach my $prop ( @{ $class->{ $propKey}}) {
	 $res .= $prop->sprint() . "\n";
      }
   }
   chomp( $res);
   return $res;
}

sub print {
   my( $class) = @_;

   print $class->sprint() . "\n";
}

=head2 getSimpleValue()

   $vCard->getSimpleValue( $prop);
   $vCard->getSimpleValue( $prop, $n);

The method will fetch the first (or, if an index is provided, the n'th) value
of the specified property. If the property or the index doesn't exist, it returns
undef

=cut

sub getSimpleValue {
   my( $class, $prop, $ndx) = ( @_, 0);		# setting ndx=0 if not provided

   my $aryRef = $class->{ uc( $prop)};
   return undef if( ! defined( $aryRef));	# property-name does not exist

   my @ary = @$aryRef;	# using aryRef directly works under perl 5.8 but not under 5.10
   my $propRef = $ary[ $ndx];
   return undef if( ! defined( $propRef));	# no index '$ndx' for the requested property

   return $propRef->{ val};
}

=head2 getSimpleValueOfType()

   $vCard->getSimpleValueOfType( $prop, [qw( WORK HOME)]]);
   $vCard->getSimpleValueOfType( $prop, [qw( WORK HOME)]], $n);

The method will fetch the first (or, if an index is provided, the n'th) value
of the specified property of the desired type. If the property or the index doesn't exist,
it returns undef

=cut

sub getSimpleValueOfType {
   my( $class, $prop, $types, $ndx) = ( @_, 0);	# setting ndx=0 if not provided
   my %h = $class->getValuesAsHash( $prop, $types);

   return ( keys %h)[ $ndx];
}

=head2 getFullName()

   $vCard->getFullName();

The method will fetch the value of the property C, and get rid off
any backslashes found in that value

=cut

sub getFullName {
   my( $class) = @_;

   my $fn = $class->getSimpleValue( 'FN');
   $fn =~ s/\\//g if( defined( $fn));
   return $fn;
}

=head2 getValuesAsHash()

   $vCard->getValuesAsHash( 'TEL', [qw( WORK HOME)]]);

The method will return a hash returning the values of the provided property.
The value will contain a CSV-list of the matching types. if no types are provided,
it will return all types found.

=cut

sub getValuesAsHash {
   my( $class, $props, $types) = @_;
   my %res = ();                                        # key=prop-value (e.g. '(07071) 82479')

   foreach my $prop ( @{ $class->{ $props}}) {          # e.g all entries with name='TEL'
      my @types = $types ? @$types : @{ $prop->{ types}};# take all types, if none required
      foreach my $type ( @types) {			# loop over all requested types
	 if( $prop->hasType( uc( $type))) {
	    push( @{ $res{ $prop->{ val}}}, $type);     # push entry in val-part of 'res'
	 }
      }
   }

   foreach ( keys %res) {  	                        # replace arrays with CSV-value (string)
      my $str = "";

      foreach ( @{ $res{ $_}}) {
	 $str .= "$_,";
      }
      chop( $str);
      $res{ $_} = $str;
   }
   return %res;
}


=head1 AUTHOR

Michael Tomuschat, C<<  >>

=head1 SEE ALSO

Text::SimpleAdrbook - A module that can read several C-files

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L. I will
be notified, and then you'll automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Text::SimpleVcard


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=head1 COPYRIGHT & LICENSE

Copyright 2008-2009 Michael Tomuschat, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

1; # End of Text::SimpleVcard