File Coverage

blib/lib/Date/Transform.pm

Criterion	Covered	Total	%
statement	278	509	54.6
branch	83	134	61.9
condition	2	6	33.3
subroutine	24	24	100.0
pod	2	2	100.0
total	389	675	57.6

package Date::Transform;

# Object Model
#
#	transform
#	+ source
#	+ filter
#	+ destination

# use lib 'C:/Documents and Settings/Christopher Brown/Desktop/CPAN';

use 5.006;
use strict;
use warnings;
use Carp;

# use Data::Dumper;
# use Benchmark qw(:all);
use Switch 'Perl5', 'Perl6';
use Tie::IxHash;
use POSIX qw(strftime);

use Date::Transform::Closures;      # Functions that create the closures.
use Date::Transform::Functions;     # Functions used in the closures
use Date::Transform::Extensions;    # Contains Extensions to Other Modules
use Date::Transform::Constants;     # Contains Constant Definitions

require Exporter;
use AutoLoader qw(AUTOLOAD);
our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Date::Manip::Transform ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

our %EXPORT_TAGS = ( 'all' => [qw()] );
our @EXPORT_OK   = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT      = qw( @CONSTANTS );

our $VERSION = '0.11';

# Preloaded methods go here.

sub new {

    my $type = shift;
    my $class = ref($type) || $type;
    my $self;

    # Arguments

    if ( scalar(@_) < 2 ) {    # Make sure that both arguments are given.
        carp("Both an input and an output arguments must be supplied.\n");
        die;
    }

    $self->{source}->{format}      = shift;
    $self->{destination}->{format} = shift;

    # Bless and return the object.
    bless $self, $class;

    $self->_initialize();

    return $self;

}

## SUBROUTINE: _initialize
##  Creates Transformation Function
sub _initialize {

    my $self = shift;

    # Expand Input & Output Formats
    #  From here on out we should deal exclusively with expanded formats.
    $self->{source}->{expanded_format} =
      _expand_compound_formats( $self->{source}->{format} );
    $self->{destination}->{expanded_format} =
      _expand_compound_formats( $self->{destination}->{format} );

    ## We can check the expanded output format for validity by making sure that none of the %_ are
    ## other than those acceptable to strftime function.  We can raise an error if they are detected.
    ##

    ## CREATE PLACE for POSIX ARRAY OF DATE
    ## sec, min, hour, mday, mon, year, wday
    ## {filter} will be the array passed to Posix::strftime
    my $ixhash_obj = Tie::IxHash->new();
    $ixhash_obj->STORE( 'format', $self->{destination}->{expanded_format} );
    $self->{filter}->{input} = $ixhash_obj;

    # Generate records of the formats and orders.
    # Retrieve input formats and order of formats.
    $self->{source}->{formats} =
      _parse_format_string( $self->{source}->{expanded_format} );
    $self->{destination}->{formats} =
      _parse_format_string( $self->{destination}->{expanded_format} );

    $self->_crosscheck
      ;    # Does the input data supply everything for necessary for the output.
    $self->_regexp;                 # Create regexp for matching.
    $self->_transform_functions;    # Create functions for mapping.

}    # END SUBROUTINE: _initialize

## SUBROUTINE: transform
##	Transforms the supplied date.
sub transform {

    my $self  = shift;
    my $input = shift;

    ## Set Defaults.
    ## my @array = $self->{filter}->{input}->Values;

    ## $matches will hold the values from the matched regular expression.
    my $matches = Tie::IxHash->new();

    ## SHOULD WE DO A  CASE INSENSITIVE MATCH -- Default: Yes.

    if ( $input =~ /$self->{filter}->{regexp}/i ) {

        ## TEMPORARILY DISABLE strict 'refs' SO THAT WE CAN USE $$n.
        no strict 'refs';

        ## Create Values from RegularExpression to Store in Cache.
        ## Foreach of the input formats,
        ##	name => value from regexp

        ## THIS IS THE SECOND MOST LIMITING STEP @ 1100/sec
        foreach ( $self->{source}->{formats}->Keys ) {
            $matches->Push( $_,
                ${ $self->{source}->{formats}->IndexFromKey($_) + 1 } );
        }

        ## REENABLE strict
        use strict 'refs';

        ## SET matches to object.
        $self->{filter}->{matches} = $matches;

        ## PERFORM EACH OF THE TRANSFORMATIONS
        ## THIS IS THE TIME LIMITING STEP @ 900/sec
        foreach my $transformation ( @{ $self->{filter}->{transformations} } ) {
            $self->$transformation;
        }

    }
    else {
        carp(
"No date matched input string, \"$input\".\nUsing Regular Expression: ",
            $self->{filter}->{regexp}, ".\n"
        );
    }

    return POSIX::strftime( $self->{filter}->{input}->Values );

}    # END SUBROUTINE: transform

## SUBROUTINE: _transform_functions
## 	Creates and stores the closures to be used in the transformation
sub _transform_functions {

    my $self = shift;

    my $required        = $self->{filter}->{requirements};
    my $supplied        = $self->{source}->{formats};
    my $filter          = $self->{filter}->{input};
    my $transformations = $self->{filter}->{transformations};

    ## 1. SECONDS
    if ( exists $required->{'S'} ) {

        # Generate second code.

        if ( $supplied->EXISTS('S') ) {

            my $f1       = mk_passthru('S');
            my $function = mk_set_filter_input( 'S', $f1 );

            push ( @{ $self->{filter}->{transformations} }, $function );

        }
        else {

            # SET DEFAULTS

        }

    }

    ## 2. MINUTES
    if ( $required->{'M'} ) {

        if ( $supplied->EXISTS('M') ) {

            my $f1       = mk_passthru('M');
            my $function = mk_set_filter_input( 'M', $f1 );

            push ( @{ $self->{filter}->{transformations} }, $function );

        }

    }

    ## 3. HOURS
    if ( exists $required->{'H'} ) {

        my $function;

        if ( $supplied->EXISTS('H') ) {

            my $f1 = mk_passthru('H');
            $function = mk_set_filter_input( 'H', $f1 );

        }
        elsif ( $supplied->EXISTS('k') ) {

            my $f1 = mk_passthru('k');
            $function = mk_set_filter_input( 'H', $f1 );

        }
        elsif ( $supplied->EXISTS('i') and $supplied->EXISTS('p') ) {

            my $f = \&iI_p_to_strftime_H;
            my $f1 = mk_function( $f, 'i', 'p' );
            $function = mk_set_filter_input( 'H', $f1 );

#= '$self->{filter}->{input}->[3] = $'	. $supplied->IndexFromKey('H');
#$function = '$self->{filter}->{input}->[3] = $'	. $supplied->IndexFromKey('H') . ' + 12' if ($ 0);

        }

        push ( @{ $self->{filter}->{transformations} }, $function );
    }

    ## 4. MONTHDAY
    if ( exists $required->{'d'} ) {

        my $function;

        if ( $supplied->EXISTS('d') ) {

            my $f1 = mk_passthru('d');
            $function = mk_set_filter_input( 'd', $f1 );

        }
        elsif ( $supplied->EXISTS('e') ) {

            my $f1 = mk_passthru('e');
            $function = mk_set_filter_input( 'd', $f1 );

        }

        push ( @{ $self->{filter}->{transformations} }, $function );

    }

    ## 5. MONTH
    if ( exists $required->{'m'} ) {

        my $function;

        if ( $supplied->EXISTS('m') ) {

            my $f = \&m_to_strftime_m;
            my $f1 = mk_function( $f, 'm' );
            $function = mk_set_filter_input( 'm', $f1 );

        }
        elsif ( $supplied->EXISTS('f') ) {

            my $f = \&m_to_strftime_m;
            my $f1 = mk_function( $f, 'f' );
            $function = mk_set_filter_input( 'm', $f1 );

        }
        elsif ( $supplied->EXISTS('b') ) {

            my $f = \&bh_to_strftime_m;
            my $f1 = mk_function( $f, 'b' );
            $function = mk_set_filter_input( 'm', $f1 );

        }
        elsif ( $supplied->EXISTS('h') ) {

            my $f = \&bh_to_strftime_m;
            my $f1 = mk_function( $f, 'h' );
            $function = mk_set_filter_input( 'm', $f1 );

        }
        elsif ( $supplied->EXISTS('B') ) {

            my $f = \&B_to_strftime_m;
            my $f1 = mk_function( $f, 'B' );
            $function = mk_set_filter_input( 'm', $f1 );

        }

        push ( @{ $self->{filter}->{transformations} }, $function );

    }

    ## 6. YEAR
    if ( exists $required->{'Y'} ) {

        my $function;

        if ( $supplied->EXISTS('y') ) {

            my $f1 = mk_passthru('y');
            $function = mk_set_filter_input( 'y', $f1 );

        }
        elsif ( $supplied->EXISTS('Y') ) {

            my $f = \&Y_to_strftime_y;
            my $f1 = mk_function( $f, 'Y' );
            $function = mk_set_filter_input( 'y', $f1 );
        }

        push ( @{ $self->{filter}->{transformations} }, $function );

    }

    return 1;

}

## SUBROUTINE: _regexp
## 	Creates the regexp used in the transformation
sub _regexp {

    ## Converts input format into regular expression format.
    my $self = shift;

    my $regexp = $self->{source}->{expanded_format};

    # Replace Special Characters
    $regexp =~ s/\%n/\\n/g;
    $regexp =~ s/\%t/\\t/g;
    $regexp =~ s/\%\%/\\%/g;
    $regexp =~ s/\%\+/\\+/g;

    foreach ( $self->{source}->{formats}->Keys ) {
        my $re_replacement = "(" . &_re($_) . ")";
        $regexp =~ s/\%($_)/$re_replacement/eg;
    }

    $self->{filter}->{regexp} = $regexp;

    # return $regexp;

}    # END SUBROUTINE: _regexp

## SUBROUTINE: _crosscheck
## 	ensures that the input string supplies all the necessary information
## 	for the requested output. Requires some complex logic (not implemented yet.)
sub _crosscheck {

# Checks to see if the necessary data elements the input_format supplies enough data.

    my $self = shift;

    # my %strftime_requirements;
    # my @req;

    # What are the output requirements.
    my %or = _strftime_requirements( $self->{destination}->{formats}->Keys );
    $self->{filter}->{requirements} = \%or;

    # What are the input supplied.
    my %is = _strftime_requirements( $self->{source}->{formats}->Keys );

    # $self->{source}->{supplied} = \%is;

    # Crosscheck outputs requested vs inputs supplied.
    #my %is = map { $_ => 1 } @is;

    foreach my $or ( sort keys %or ) {

        if ( !$is{$or} ) {
            carp
"WARNING: %$or is required by the output, but not supplied by the input.\n";

            # die("\n") unless ( $is{$or} );
        }

    }

}

## SUBROUTINE: _parse_format_string
##	Given a date string => href of elements in the string, aref of order of elements
##		Because we reverse the format string ... walking it backwards ... if an element
##		appears more than once, the REAL first occurence will be captured.
sub _parse_format_string {

    # Format String => href Elements in Sting, aref order of elements

    my $format = shift;
    my $index  = 0;

    my $ixhash_obj = Tie::IxHash->new();

    $format = reverse($format);    # REVERSE THE ORDER OF FORMAT.

    # my $elements;
    # my $order;

    my ( $r1, $r2 );

    $r1 = chop($format);

    while ($format) {

        $r2 = $r1;
        $r1 = chop($format);

        # Test for format field.
        if ( $r2 eq '%' ) {

    # $elements->{$r1} =  undef;  # These will become storage recepticles later.
    # push @{$order}, $r1;

# Since date information might appear twice in the string, we only want to take the first instance.
# next if ( $ixhash_obj->[0]->{$r1} );
# Make sure to put the new formats at the front of object.
            $ixhash_obj->Push( $r1 => $index );
            $r1 = chop($format);

            $index++;
        }

    }

    return $ixhash_obj;

}

########################

## SUBROUTINE: _expand_compound_formats
## 	Expands compound formats to full formats.
sub _expand_compound_formats {

    my $format = shift;
    my ( $expansion, $new_format );

    $format = reverse $format;

    my ( $r1, $r2 );
    $r1 = chop $format;

    while ($format) {

        $r2 = $r1;
        $r1 = chop($format);

        my $expansion;

        # Test for format field.
        if ( $r2 eq '%' ) {

            given($r1) {

                # COMPUND FORMATS

                when [ "T", "X" ] { $expansion = "%H:%M:%S"; }
                when "c" { $expansion = "%a %b %e %H:%M:%S %z %Y"; }
                when [ "C", "u" ] { $expansion = "%a %b %e %H:%M:%S %z %Y"; }
                when "g" { $expansion = "%a, %d %b %Y %H:%M:%S %z"; }
                when [ "D", "x" ] { $expansion = "%m/%d/%y"; }

                when "r" { $expansion = "%I:%M:%S %p"; }
                when "R" { $expansion = "%H:%M"; }
                when "V" { $expansion = "%m%d%H%M%y"; }
                when "Q" { $expansion = "%Y%m%d"; }
                when "q" { $expansion = "%Y%m%d%H%M%S"; }
                when "P" { $expansion = "%Y%m%d%H:%M:%S"; }
                when "F" { $expansion = "%A, %B %e, %Y"; }
                when "J" { $expansion = "%G-%W-%w"; }
                when "K" { $expansion = "%Y-%j"; }

# when ""	{ $re = '' } # MORE.
# when "l"	{ $re = "[" . join( ' ', _re(b,e,R) ) . '|' . join( ' ', _re(b,e,Y) ) . "]" }
# Omitted for now, but logic can be included to solve the problem.

                # Don't expand non compound factors
                else { $expansion .= $r2 . $r1; }

            }    # End SWITCH

            $r1 = chop($format);

        }
        else {

            $expansion = $r2;

        }    # END if

        $new_format .= $expansion;

    }    # END format WHILE

    return $new_format;

}

## SUBROUTINE: _strftime_requirements
##	Given a series of formats that are requested,
## 	This function determines what is required by
##	strftime to suppy those requirements.
sub _strftime_requirements {

    # OUTPUT REQUIREMENTS
    # my $format;
    my @formats = @_;
    my @req;

    foreach my $format (@formats) {

        given($format) {

            # Year
            when [ "Y", "y", "G", "L" ] { push ( @req, 'Y' ); }

            # Month
            when [ "m", "f", "b", "h", "B" ] { push ( @req, 'm' ); }

            # Week/Day of the year, Day of the week
            when [ "U", "W", "j", "v", "a", "A", "w" ] {
                push ( @req, 'Y', 'm', 'd' );
            }

            # Day of the Month
            when [ "d", "e", "E" ] { push ( @req, 'd' ); }

            # Hour
            when [ "H", "k", "i", "l", "p" ] { push ( @req, 'H' ); }

            # Minute
            when ["M"] { push ( @req, 'M' ); }

            # Second
            when ["S"] { push ( @req, 'S' ); }

        }    # END SWITCH BLOCK

    }    # END @formats LOOP

    # Remove duplicates from requirements
    my %req = map { $_ => 1 } @req;

    return %req;    # return (keys(%req));

}

sub _re {

    # Generate regular expression for the given format(s)
    # In general the regular expressions should be
    # restrictive and fast.
    #

    my $format = shift;

    # my $regexp;

    my $re;

    given($format) {

        # YEAR
        when "y" { $re = '\d{2}'; }
        when [ "Y", "G", "L" ] { $re = '\d{4}'; }

        #Month
        when "m" { $re = '[01]\d'; }
        when "f" { $re = '\d{1}|1[0-2]'; }
        when [ "b", "h" ] {
            $re = 'Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec';
        }
        when "B" {
            $re =
'January|February|March|April|May|June|July|August|September|October|November|December';
        }
        when [ "U", "W" ] { $re = '[0-5]\d'; }

        # Day
        when "j" { $re = '[0-3]\d{2}'; }
        when "d" { $re = '[0-3]\d'; }
        when "e" { $re = '[ |0|1|2|3]\d'; }
        when "v" { $re = ' S| M| T| W|Th|F|Sa'; }
        when "a" { $re = 'Sun|Mon|Tue|Wed|Thu|Fri|Sat'; }
        when "A" {
            $re = 'Sunday|Monday|Tuesday|Wednesday|Thursday|Friday|Saturday';
        }
        when "w" { $re = '1-7'; }
        when "E" { $re = '\d{1,2}st|nd|rd|th'; }

        # Hours
        when "H" { $re = '[0-2]\d'; }
        when "k" { $re = '[ 12]\d'; }
        when "i" { $re = '[ 1]\d'; }
        when "I" { $re = '[01]\d'; }
        when "p" { $re = 'AM|PM'; }

        when [ "M", "S" ] { $re = '[0-6]\d'; }

        else { carp "No Regular Expression found for POSIX format -- $format"; }

    }    # END case BLOCK

    return $re

}    # END SUBROUTINE _re

# Autoload methods go after =cut, and are processed by the autosplit program.

1;

__END__;