dates.pm

普通的ETL工具

# vim:ts=4 sw=4
# ----------------------------------------------------------------------------------------------------
#  Name		: ETL::Pequel3::Type::Dates.pm
#  Created	: 9 May 2006
#  Author	: Mario Gaffiero (gaffie)
#
# Copyright 1999-2007 Mario Gaffiero.
# 
# This file is part of Pequel(TM).
# 
# Pequel is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
# 
# Pequel is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with Pequel; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
# ----------------------------------------------------------------------------------------------------
# Modification History
# When          Version     Who     What
# ----------------------------------------------------------------------------------------------------
package ETL::Pequel3::Type::Dates;
require 5.005_62;
use strict;
use warnings;
# ----------------------------------------------------------------------------------------------------
{
	package ETL::Pequel3::Type::Dates::Part;
	use base qw(Class::STL::Element);
	use base qw(Class::STL::ClassMembers::DataMember);
	use Class::STL::ClassMembers qw( pos len );
	use Class::STL::ClassMembers::Constructor;
}
# ----------------------------------------------------------------------------------------------------
{
	package ETL::Pequel3::Type::Dates::Abstract;
	use base qw(Class::STL::Element);
	use base qw(Class::STL::ClassMembers::DataMember);
	use Class::STL::ClassMembers qw( name d m y delimiter regex ),
		Class::STL::ClassMembers::DataMember->new(name => 'xs_type', default => 'token');
	use Class::STL::ClassMembers::Constructor;
	use Class::CodeStyler;
	sub new_extra
	{
		my $self = shift;
		$self->d(ETL::Pequel3::Type::Dates::Part->new(
			pos => index($self->name(), 'D'),
			len => rindex($self->name(), 'D') - index($self->name(), 'D') +1));
		$self->m(ETL::Pequel3::Type::Dates::Part->new(
			pos => index($self->name(), 'M'),
			len => rindex($self->name(), 'M') - index($self->name(), 'M') +1));
		$self->y(ETL::Pequel3::Type::Dates::Part->new(
			pos => index($self->name(), 'Y'),
			len => rindex($self->name(), 'Y') - index($self->name(), 'Y') +1));
		$self->delimiter((grep(!/[DMY]/i, split(//, $self->name())))[0]);
		if 
		(
			!defined($self->regex())
			&& $self->name() =~ /D{2}/
			&& $self->name() =~ /M{2,3}/
			&& ($self->name() =~ /Y{2}/ || $self->name() =~ /Y{4}/)
		)
		{
			my $regex = $self->name();
			$regex =~ s/(?![D|M|Y])/\\/g;
			$regex =~ s/\\$//;
			$regex =~ s/(D+)/\\d{@{[ length($1) ]}}/;
			$regex =~ s/MMM/\\w{3}/;
			$regex =~ s/MM/\\d{2}/;
			$regex =~ s/(Y+)/\\d{@{[ length($1) ]}}/;
			$self->regex($regex);
		}
		return $self;
	}
    sub code_cmp_date
	{ 
		my $self = shift; 
		my $d1 = shift;
		my $d2 = shift;
		my $c = Class::CodeStyler::Program::Perl->new();

		$c->code('my $cmp;');
		$c->code("if ($d1 eq $d2) { \$cmp = 0; }");
		$c->code("else {");
		$c->over();
		#TODO: cmp = (y1 <=> y2) || (m1 <=> m2) || (d1 <=> d2);
			if ($self->y()->len() == 2)
			{
				$c->code("my \$yr1 = (int(substr(qq{$d1}, @{[ $self->y()->pos() ]}, 2)) < 20 ? '20' : '19') . substr(qq{$d1}, @{[ $self->y()->pos() ]}, 2)");
				$c->code("my \$yr2 = (int(substr(qq{$d2}, @{[ $self->y()->pos() ]}, 2)) < 20 ? '20' : '19') . substr(qq{$d2}, @{[ $self->y()->pos() ]}, 2)");
				$c->code("if ((\$cmp = ((\$yr1 . substr($d1, @{[ $self->y()->pos() ]}, 2)) <=> (\$yr2 . substr($d2, @{[ $self->y()->pos() ]}, 2)))) == 0) {");
			}
			else
			{
				$c->code("if ((\$cmp = (substr($d1, @{[ $self->y()->pos() ]}, 4) <=> substr($d2, @{[ $self->y()->pos() ]}, 4))) == 0) {");
			}
			$c->over;
				if ($self->m()->len() == 2)
				{
					$c->newline_off();
					$c->code("if ((\$cmp = (substr($d1, @{[ $self->m->pos ]}, @{[ $self->m->len ]}) ");
					$c->newline_on();
					$c->code("<=> substr($d2, @{[ $self->m()->pos() ]}, @{[ $self->m()->len() ]}))) == 0) {");
				}
				else
				{
					$c->newline_off();
					$c->code("if ((\$cmp = (&month_number(substr($d1, @{[ $self->m()->pos() ]}, @{[ $self->m()->len() ]})) ");
					$c->newline_on();
					$c->code("<=> &month_number(substr($d2, @{[ $self->m()->pos() ]}, @{[ $self->m()->len() ]})))) == 0) {");
				}
				$c->over;
					$c->newline_off();
					$c->code("\$cmp = (substr($d1, @{[ $self->d()->pos() ]}, @{[ $self->d()->len() ]}) ");
					$c->newline_on();
					$c->code("<=> substr($d2, @{[ $self->d()->pos() ]}, @{[ $self->d()->len() ]}));");
				$c->back();
				$c->code("}");
			$c->back();
			$c->code("}");
		$c->back();
		$c->code("}");
		return $c;
	}
	sub code_to_CCYYMMDD
	{
		my $self = shift;
		my $dt = shift;
		my $c = Class::CodeStyler::Program::Perl->new();
		$c->newline_off();
		$c->code("scalar(");
		($self->y()->len() == 4)
			? $c->code("substr(qq{$dt}, @{[ $self->y()->pos() ]}, 4)")
			: $c->code("(int(substr(qq{$dt}, @{[ $self->y()->pos() ]}, 2)) < 20 ? '20' : '19') . substr(qq{$dt}, @{[ $self->y()->pos() ]}, 2)");
		($self->m()->len() == 2)
			? $c->code(". substr(qq{$dt}, @{[ $self->m()->pos() ]}, 2)")
			: $c->code(". &month_number(substr(qq{$dt}, @{[ $self->m()->pos() ]}, @{[ $self->m()->len() ]}))");
		$c->code(". substr(qq{$dt}, @{[ $self->d()->pos() ]}, 2)");
		$c->code(")");
		return $c;
	}
	sub from_dmy
	{
		my $self = shift;
		my $d = shift; # exp returning day-number
		my $m = shift; # exp returning month-number
		my $y = shift; # exp returning CCYY year-number
		my @dmy_order = $self->dmy_order();
		my %date = (
			D => "sprintf('%02d', $d)",
			M => ($self->m()->len() == 3 ? "&month_abbr($m)" : "sprintf('%02d', $m)"),
			Y => ($self->y()->len() == 2 ? "substr($y, 2)" : $y)
		);
		return join(
			(defined($self->delimiter()) ? " . '@{[ $self->delimiter() ]}' . " : " . "), 
			$date{$dmy_order[0]},
			$date{$dmy_order[1]},
			$date{$dmy_order[2]}
		);
	}
	sub dmy_order
	{
		my $self = shift;
		my $order = $self->name();
		$order =~ y///cs;
		return defined($self->delimiter()) 
			? map(uc, split(/@{[ $self->delimiter() ]}/, $order))
			: map(uc, split(//, $order));
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package ETL::Pequel3::Type::Dates::YYYYMMDD;
	use base qw(ETL::Pequel3::Type::Dates::Abstract);
	use Class::STL::ClassMembers
		Class::STL::ClassMembers::DataMember->new(name => 'name', default => 'YYYYMMDD');
	use Class::STL::ClassMembers::Constructor;
	sub code_to_CCYYMMDD
	{
		my $self = shift;
		my $d = shift;
		my $c = Class::CodeStyler::Program::Perl->new();
		$c->code("scalar(qq{$d})");
		return $c;
	}
    sub code_cmp_date : method 
	{ 
		my $self = shift; 
		my $d1 = shift;
		my $d2 = shift;
		my $c = Class::CodeStyler::Program::Perl->new();
		$c->code("my \$cmp = $d1 <=> $d2;");
		return $c;
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package ETL::Pequel3::Type::Dates::YYMMDD;
	use base qw(ETL::Pequel3::Type::Dates::Abstract);
	use Class::STL::ClassMembers
		Class::STL::ClassMembers::DataMember->new(name => 'name', default => 'YYMMDD');
	use Class::STL::ClassMembers::Constructor;
    sub code_cmp_date
	{ 
		my $self = shift; 
		my $d1 = shift;
		my $d2 = shift;
		my $c = Class::CodeStyler::Program::Perl->new();
		$c->code("my \$yr1 = substr($d1, 0, 2) < 20 ? '20' : '19';");
		$c->code("my \$yr2 = substr($d2, 0, 2) < 20 ? '20' : '19';");
		$c->code("my \$cmp = scalar(\$yr1 . $d1) <=> scalar(\$yr2 . $d2);");
		return $c;
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package ETL::Pequel3::Type::Dates::FindName;
	use base qw(Class::STL::Utilities::FunctionObject::UnaryFunction);
	use Class::STL::ClassMembers qw( name );
	use Class::STL::ClassMembers::Constructor;
	sub function_operator
	{
		my $self = shift;
		my $arg = shift; # element object
		return $arg->name() eq $self->name() ? $arg : 0;
	}
}
# ----------------------------------------------------------------------------------------------------
{
	package ETL::Pequel3::Type::Dates::Catalogue;
	use base qw(ETL::Pequel3::Type::Catalogue);
	use Class::STL::ClassMembers
		Class::STL::ClassMembers::DataMember->new(name => 'catalogue_name', default => 'date_types'),
		Class::STL::ClassMembers::DataMember->new(name => 'target_mem_name', default => 'name'),
		Class::STL::ClassMembers::DataMember->new(name => 'element_type', default => 'ETL::Pequel3::Type::Dates::Abstract');
	use Class::STL::ClassMembers::SingletonConstructor;
	sub new_extra
	{
		my $self = shift;
		$self->push_back(
			ETL::Pequel3::Type::Dates::YYYYMMDD->new(),
			ETL::Pequel3::Type::Dates::YYMMDD->new(),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'DD/MM/YYYY'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'DD/MM/YY'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'DDMMYY'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'DDMMYYYY'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'DDMMMYY'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'MM/DD/YYYY'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'MM/DD/YY'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'MMDDYY'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'MMDDYYYY'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'YYYY-MM-DD'),
			ETL::Pequel3::Type::Dates::Abstract->new(name=>'YY-MM-DD'),
		);
		return $self;
	}
	sub catalogue
	{
		my $self = shift;
		my $xml_node = shift;
		foreach ($self->to_array()) {
			my $s_xml = $xml_node->createChild("date-type");
			$s_xml->attribute('date-name', $_->name());
				my $m_xml = $s_xml->createChild("property");
				$m_xml->attribute('regex', $_->regex());
				$m_xml->attribute('delimiter', $_->delimiter()) if (defined($_->delimiter()));
		}
	}
}
# ----------------------------------------------------------------------------------------------------
1;