File Coverage

blib/lib/Net/ICal/Property.pm

Criterion	Covered	Total	%
statement	17	82	20.7
branch	1	28	3.5
condition			n/a
subroutine	4	9	44.4
pod	3	3	100.0
total	25	122	20.4

#!/usr/bin/perl -w
# -*- Mode: perl -*-
#======================================================================
#
# This package is free software and is provided "as is" without
# express or implied warranty.  It may be used, redistributed and/or
# modified under the same terms as perl itself. ( Either the Artistic
# License or the GPL. )
#
# $Id: Property.pm,v 1.16 2001/08/04 04:59:36 srl Exp $
#
# (C) COPYRIGHT 2000-2001, Reefknot developers.
#
# See the AUTHORS file included in the distribution for a full list.
#======================================================================

# eek. 44 subclasses

=head1 NAME

Net::ICal::Property -- base class for ICalender properties

=cut

package Net::ICal::Property;
use strict;

use UNIVERSAL;
use base qw(Class::MethodMapper);

=head1 SYNOPSIS

Creating a property from a ical string:
    $p = Net::ICal::Property->new_from_ical ($str);

print out an ical string
    print $p->as_ical;

=head1 DESCRIPTION

This is the base class from which you derive specific ICal properties.

=head1 CONSTRUCTORS

=head2 new ($name, $map, %args)

You never call this directly. Instead you call the new constructor for
a specific property type, which in turn calls this:

    $p = Net::ICal::Trigger (300);

=begin testing

TODO: {
    local $TODO = "We need to write tests here";

    ok(0, 'write tests for new()');

}
=end testing

=cut

sub new {
   my ($classname, $name, $map, %args) = @_;

   if (not defined $map->{content}) {
      warn "not a proper property\n";
      return undef;
   }

   $map->{name} = {
      type => 'volatile',
      doc => 'the ICalendar name of the property',
      value => $name,
   };

   my $self = new Class::MethodMapper;
   bless $self, $classname;
   $self->set_map (%$map);
   $self->set (%args);

   return $self;
}

=begin testing

# TODO: write tests
TODO: {
    local $TODO = "write tests here, please; patches welcome";
    ok(0, 'write tests for _reclass_set()');
}
=end testing

=cut
sub _reclass_set {
   my ($self, $key, $val) = @_;

   my ($class) = $self =~ /^(.*?)=/g;

   foreach my $pclass (values %{$self->get_meta ('options', $key)}) {
      if (UNIVERSAL::isa ($val, $pclass)) {
	 $self->{$key}->{value} = $val;
	 return;
      }
   }
   warn "${class}->$key: '$val' is not a type of class. "
      . "using 'undef' instead.\n";
   $self->{$key}->{value} = undef;
}

=head2 new_from_ical ($ical)

Creates a new Net::ICal property from a string in ICal format

=begin testing

# TODO: write tests
TODO: {
    local $TODO = 'write tests here please';
    ok(0, 'write tests for new_from_ical()');
}
=end testing

=cut

sub new_from_ical {
   my ($class, $ical) = @_;

   my ($prop) = $ical =~ /^(\w+)[;:]/g;
   unless ($prop) {
      warn "Not a valid ical stream\n";
      return undef;
   }
   my $self = $class->_create;

   my $cb = sub {
      return undef if $ical eq "";
      if ($ical =~ /^;/) {
	 #FIXME: make this more robust (; in "" inside a field is possible
	 #BUG: 133739
	 $ical =~ s/;(.*?)\=(.*?)(;|$)/$3/;
	 #FIXME: make sure we definitely don't need anything but plain
	 #       key/value
	 my ($name, $value) = ($1, $2);
	 $name =~ s/\W/_/g;
	 return (lc($name), $value);
      } else {
	 $ical =~ s/^.*?([;:])/$1/;
	 # this too
	 $ical =~ s/:(.*?)$//;
	 my $value = $1;

	 # Check if this is a property that can be one of several
	 # classes. determine what class with regexps
	 if ($self->get_meta ('domain', 'content')) {
	    if ($self->get_meta ('domain', 'content') eq 'reclass') {
	       my %rehash = %{$self->get_meta ('options', 'content')};
	       my $default = delete $rehash{'default'};
	       foreach my $re (keys %rehash) {
		  if ($value =~ /$re/) {
		     my $class = $rehash{$re};
		     eval "require $class";
		     my $param = $class->new ($value);
		     return ('content', $param);
		  }
	       }
	       eval "require $default";
	       my $param = $default->new ("$value");
	       return ('content', $param);
	    }
	 #FIXME: we may need to handle 'ref' and 'enum' domains too
	 } else {
	    return ('content', $value);
	 }
      }
   };
   $self->restore ($cb);
   return $self;
}

=head1 METHODS

=head2 name([$name])

Get or set the name of the property. You're not supposed to actually
ever set this manually. It will be set by the new method of the
property type you are creating.

=head2 as_ical

returns an ICal string describing the property

=begin testing

# TODO: write tests
TODO: {
    local $TODO = "write these tests";
    ok(0, 'write tests for as_ical()');
}
=end testing

=cut

sub as_ical {
   my ($self) = @_;
   my $ical;

   my $cb = sub {
      my ($self, $key, $value) = @_;
      $key =~ s/_/-/g;
      $key = uc ($key);

      return unless defined $value->{value};
      if ($value->{domain} eq 'ref') {
	 if ($value->{options} eq 'ARRAY') {
	    foreach my $val (@{$value->{value}}) {
	       if (ref ($val)) {
		  $ical .= ";" . $key . "=" . $val->as_ical_value();
	       } else {
		  $ical .= ";" . $key . "=$val";
	       }
	    }
	 } elsif ($value->{options} eq 'HASH') {
	    # hash param (FIXME: will this ever be used?)
	 } else {
	    # assume it's a class
	    $ical .= ";" . $key . "=" . $value->{value}->as_ical_value;
	 }
      } else {
	 $ical .= ";" . $key . "=" . $value->{value};
      }
   };

   $self->save ('parameter', $cb);

   if (ref ($self->content)) {
      $ical .= ":" . $self->content->as_ical_value;
   } else {
      $ical .= ":" . $self->content;
   }
   return $ical;
}

1;

=head1 SEE ALSO

L, L

=cut