File Coverage

blib/lib/Date/Formatter.pm

Criterion	Covered	Total	%
statement	206	210	98.1
branch	68	70	97.1
condition	38	51	74.5
subroutine	50	52	96.1
pod	42	42	100.0
total	404	425	95.0

package Date::Formatter;
{
  $Date::Formatter::VERSION = '0.11';
}

use strict;
use warnings;

use Scalar::Util qw(blessed);

use Time::Local ();
use DateTime::Locale;

## overload operators
use overload (
	'""'  => "toString",
	'=='  => "equal",
	'!='  => "notEqual",
	'<=>' => "compare",
	'+'   => "add",
	'-'   => "subtract"
	);

### constructor

sub new {
	my ($_class, %date) = @_;
	my $class = ref($_class) || $_class;
	my $date = {};
	bless($date, $class);
	$date->_init(%date);
	return $date;
}


sub now {
    my ( $self, %date ) = @_;
    my $locale = $date{locale} || 'en';
    return $self->new( locale => $locale );
}

sub _init {
	my ($self, %date) = @_;
	$self->{hourType} = 12;
	$self->{abbreviateMonths} = 0;
	$self->{abbreviateDays} = 0;
	$self->{formatter} = undef;
	$self->{internal} = undef;
	$self->{elements} = [];
	$self->{am_or_pm} = undef;
	$self->{gmt_offset_hours} = undef;
	$self->{gmt_offset_minutes}	= undef;

    $self->setLocale( delete $date{locale} );

    if (%date) {
        # we let Time::Local do the range checking
        # on these values here,..
        $date{seconds}      = 0 unless exists $date{seconds};
        $date{minutes}      = 0 unless exists $date{minutes};
        $date{hour}         = 0 unless exists $date{hour};
        $date{year}         = 0 unless exists $date{year};
        $date{day_of_month} = 1 unless exists $date{day_of_month};
        # we accept normal month values
        # instead of zero index months
        if (exists $date{month}) {
            ($date{month} =~ /^\d+$/ && $date{month} >= 1)
                || die "Insufficient Arguments : 'month' value must be numeric and at least 1";
            $date{month} -= 1;
        }
        else {
        	$date{month} = 0;
        }
        my $new_time;
        eval {
            $new_time = Time::Local::timelocal(
                            $date{seconds}, $date{minutes}, $date{hour},
                            $date{day_of_month}, $date{month}, $date{year}
                        );
        };
        die "Insufficient Arguments : Could not construct a proper date value : $@" if $@;
        $self->_setTime($new_time);
    }
    else {
        $self->_setTime(time());
    }
}

sub setLocale {
    my $self = shift;
    my ($locale) = @_;

    $locale ||= 'en';

    $self->{locale} = DateTime::Locale->load( $locale );

    return;
}

## alternate constructor
# for creating intervals of time.
# --------------------------------------
# this is best used with the overloaded
# versions of the '+' and '-' operator
# to increment and decrement another
# date object.
#
# Accepts the following named arguments:
#  - > years (365 days)
#  - > leap years (366 days)
#  - > months (assumes 30 days)
#  - > weeks
#  - > days
#  - > hours
#  - > minutes
#  - > seconds
#
# NOTE:
# This can also be used to set a time
# sometime past the epoch, but that is
# not terribly useful. Except maybe to
# pass in nothing and get the date of the
# epoch on your current system.
sub createTimeInterval {
	my ($class, %_date) = @_;
	my $time = 0;
	if (exists($_date{years}) && $_date{years}){
		$time += $_date{years} * 365 * 24 * 60 * 60;
	}
	if (exists($_date{leapyears}) && $_date{leapyears}){
		$time += $_date{leapyears} * 366 * 24 * 60 * 60;
	}
	if (exists($_date{months}) && $_date{months}){
		$time += $_date{months} * 30 * 24 * 60 * 60;
	}
	if (exists($_date{weeks}) && $_date{weeks}){
		$time += $_date{weeks} * 7 * 24 * 60 * 60;
	}
	if (exists($_date{days}) && $_date{days}){
		$time += $_date{days} * 24 * 60 * 60;
	}
	if (exists($_date{hours}) && $_date{hours}){
		$time += $_date{hours} * 60 * 60;
	}
	if (exists($_date{minutes}) && $_date{minutes}){
		$time += $_date{minutes} * 60;
	}
	if (exists($_date{seconds}) && $_date{seconds}){
		$time += $_date{seconds};
	}
	# if the are asking for nothing then
	# give them 1 second past the epoch
	$time ||= 1;
	return _setTime($class->new(), $time);
}

# occasionally you will want to refresh
# the time to be the current time. This
# would allow a Date object to be used
# over a long period of time
sub refresh {
	my ($self) = @_;
	$self->_init();
	return $self;
}

# creates a formatter subroutine to be used when
# the date object is printed:
# 	print $date;
# (see below for more documentation)
{

	my %_parser_table = (
		"MM" 	=> \&getNumericMonth,
		"M" 	=> \&getMonth,
		"DD" 	=> \&getDayOfMonth,
		"D" 	=> \&getDayOfWeek,
		"YY" 	=> \&getYear,
		"YYYY" 	=> \&getFullYear,
		"hh" 	=> \&getHours,
		"mm" 	=> \&getMinutes,
		"ss" 	=> \&getSeconds,
		"T" 	=> \&isAMorPM,
		"O"		=> \&getGMTOffset
	);

	sub createDateFormatter {
		my ($self, $format, $pattern) = @_;
		my @date_format;
		$pattern ||= qr/\(|\)/;
		my @tokens = split $pattern => $format;
		while (@tokens) {
			my $token = shift(@tokens);
			if (exists $_parser_table{$token}) {
				push @date_format, $_parser_table{$token};
			}
			else {
				push @date_format, sub{ return "$token" };
			}
		}
		$self->{formatter} = sub {
			my ($self) = @_;
			return join "" => map {
				$_->($self);
			} @date_format;
		};
		return $self;
	}

}

sub getDateFormatter {
	my ($self) = @_;
	return $self->{formatter};
}

sub setDateFormatter {
	my ($self, $formatter) = @_;
	(defined($formatter) && ref($formatter) eq "CODE")
        || die "Insufficient Arguments : bad formatter";
	$self->{formatter} = $formatter;
}

## private

# special private subroutine
# to set the internal time of
# a date object after it is
# created. This is used by:
# - createTimeInterval
# - add
# - subtract
sub _setTime {
	my ($date, $new_time) = @_;
	$date->{internal} = $new_time;
	$date->{elements} = [ localtime($new_time) ];
	# must undefine this so that
	# it gets re-generated
	$date->{am_or_pm} = undef;
	my ($gmt_minutes, $gmt_hours) = (gmtime($new_time))[1, 2];
	$date->{gmt_offset_hours} = ($date->{elements}->[2] - $gmt_hours);
	$date->{gmt_offset_minutes} = ($date->{elements}->[1] - $gmt_minutes);
	return $date;
}

## configuration

# use 12 or 24 hour clock
sub use24HourClock {
	my ($self) = @_;
	$self->{hourType} = 24;
}

sub use12HourClock {
	my ($self) = @_;
	$self->{hourType} = 12;
}

# use short or long names for months and days
sub useLongNames {
	my ($self) = @_;
	$self->{abbreviateMonths} = 0;
	$self->{abbreviateDays} = 0;
}

sub useLongMonthNames {
	my ($self) = @_;
	$self->{abbreviateMonths} = 0;
}

sub useLongDayNames {
	my ($self) = @_;
	$self->{abbreviateDays} = 0;
}

# short names are the first 3 letters
sub useShortNames {
	my ($self) = @_;
	$self->{abbreviateMonths} = 1;
	$self->{abbreviateDays} = 1;
}

sub useShortMonthNames {
	my ($self) = @_;
	$self->{abbreviateMonths} = 1;
}

sub useShortDayNames {
	my ($self) = @_;
	$self->{abbreviateDays} = 1;
}


## informational

sub isAMorPM {
	my ($self) = @_;
	return if ($self->{hourType} == 24);
	$self->getHours() unless $self->{am_or_pm};
	return $self->{am_or_pm};
}

sub getSeconds {
	my ($self) = @_;
	return sprintf("%02d", $self->{elements}->[0]);
}

sub getMinutes {
	my ($self) = @_;
	return sprintf("%02d", $self->{elements}->[1]);
}

sub getHours {
	my ($self) = @_;
	if ($self->{hourType} == 12){
		my $hours = $self->{elements}->[2];
		if ($hours == 12){
			$self->{am_or_pm} = "p.m.";
			return 12;
		}
		elsif ($hours == 0) {
			$self->{am_or_pm} = "a.m.";
			return 12;
		}
		elsif ($hours < 12){
			$self->{am_or_pm} = "a.m.";
			return $hours;
		}
		elsif ($hours > 12){
			$self->{am_or_pm} = "p.m.";
			return $hours - 12;
		}
	}
	return $self->{elements}->[2];
}

# GMT offsets

# ... by hours
sub getGMTOffsetHours {
	my ($self) = @_;
	return $self->{gmt_offset_hours};
}

# ... by minutes
sub getGMTOffsetMinutes {
	my ($self) = @_;
	return $self->{gmt_offset_minutes};
}

# and finally a formatted offset
sub getGMTOffset {
	my ($self) = @_;
	my $gmt_offset = abs($self->{gmt_offset_hours});
	my $sign = "";
	$sign = "-" if ($gmt_offset > $self->{gmt_offset_hours});
	return sprintf("%s%02d00", ($sign, $gmt_offset));
}

sub getDayOfMonth {
	my ($self) = @_;
	return $self->{elements}->[3];
}

sub getMonth {
	my ($self) = @_;
	if ($self->{abbreviateMonths} == 1){
        return $self->{locale}->month_format_abbreviated->[$self->{elements}[4]];
	}
    return $self->{locale}->month_format_wide->[$self->{elements}[4]];
}

sub getNumericMonth {
	my ($self) = @_;
	return $self->{elements}->[4] + 1;
}

sub getMonthIndex {
	my ($self) = @_;
	return $self->{elements}->[4];
}

sub getFullYear {
	my ($self) = @_;
	return (1900 + $self->{elements}->[5]);
}

sub getYear {
	my ($self) = @_;
	return sprintf("%02d", ($self->{elements}->[5] % 100));
}

sub getDayOfWeek {
	my ($self) = @_;

    my @days;
	if ($self->{abbreviateDays} == 1){
        @days = @{$self->{locale}->day_format_abbreviated};
	}
    else {
        @days = @{$self->{locale}->day_format_wide};
    }

    # DateTime::Locale has Monday as the first day. This module
    # uses Sunday. So, move the last item to the front, so @days
    # is now Sunday -> Saturday instead of Monday -> Sunday.
    unshift(@days, pop(@days));

	return $days[$self->{elements}->[6]];
}

sub getDayOfWeekIndex {
	my ($self) = @_;
	return $self->{elements}->[6];
}

sub getDayOfYear {
	my ($self) = @_;
	return $self->{elements}->[7];
}

### overloaded interfaces

sub clone {
	my ($self) = @_;
	return $self->unpack($self->pack());
}

## serialization

sub pack {
	my ($self) = @_;
	return $self->{internal};
}

sub unpack {
	# this is an alternate constructor
	my ($class, $packed_string) = @_;
	my $obj = _setTime($class->new(), $packed_string);

    #Uncomment if you want clones to clone the locale, as well
    #$obj->{locale} = $self->{locale};

    return $obj;
}

## printing

sub toString {
	# this could be more
	# robust to take advantage of
	# the module configurations
	my ($self) = @_;
	return $self->{formatter}->($self) if $self->{formatter};
	return scalar localtime($self->{internal});
}

# return the unmolested object string
sub stringValue {
	my ($self) = @_;
	return overload::StrVal($self);
}

### overloaded operators

# Addition and Subtraction operators are
# best used in conjunction with a Data object that
# has been create using the createTimeInterval
# constructor.

sub add {
	my ($left, $right) = @_;
	(blessed($right) && $right->isa("Date::Formatter"))
		|| die "Illegal Operation : Cannot add a date object to a non-date object.";
	return _setTime($left->clone(), $left->{internal} + $right->{internal});
}

# sub addEqual {
# 	my ($left, $right) = @_;
# 	((ref($left) eq "Date::Formatter") && (ref($right) eq "Date::Formatter")) || die "IllegalOperation : IllegalOperation : Cannot add a date object to a non-date object.";
# 	return $left->_setTime($left->{internal} + $right->{internal});
# }

sub subtract {
	my ($left, $right) = @_;
	(blessed($right) && $right->isa("Date::Formatter"))
		|| die "Illegal Operation : Cannot subtract a date object from a non-date object.";
	return _setTime($left->clone(), $left->{internal} - $right->{internal});
}

# sub subtractEqual {
# 	my ($left, $right) = @_;
# 	((ref($left) eq "Date::Formatter") && (ref($right) eq "Date::Formatter")) || die "IllegalOperation : Cannot subtract a date object from a non-date object.";
# 	return $left->_setTime($left->{internal} - $right->{internal});
# }

# compare two dates
sub compare {
	my ($left, $right) = @_;
	(blessed($right) && $right->isa("Date::Formatter"))
		|| die "Illegal Operation : Cannot compare a date object to a non-date object.";
	return ($left->{internal} <=> $right->{internal});
}

sub equal {
	my ($left, $right) = @_;
	return ($left->compare($right) == 0) ? 1 : 0;
}

sub notEqual {
	my ($left, $right) = @_;
	return ($left->equal($right)) ? 0 : 1;
}


1;

__END__