App-olson

 view release on metacpan or  search on metacpan

lib/App/olson.pm  view on Meta::CPAN

use Params::Classify 0.000 qw(is_string);
use Time::OlsonTZ::Data 0.201012 ();
use Time::Unix 1.02 qw(time);

our $VERSION = "0.000";

#
# list utilities
#

sub _all(&@) {
	my $match = shift(@_);
	foreach(@_) {
		return 0 unless $match->($_);
	}
	return 1;
}

#
# exceptions
#

sub _is_exception($) {
	return is_string($_[0]) && $_[0] =~ /\A[!?~]\z/;
}

sub _cmp_exception($$) { $_[0] cmp $_[1] }

#
# calendar dates
#

sub _caltime_offset($$) {
	my($rdns, $offset) = @_;
	return $rdns if _is_exception($rdns);
	return $offset if _is_exception($offset);
	my($rdn, $sod) = @$rdns;
	$sod += $offset;
	use integer;
	my $doff = $sod < 0 ? -((86399-$sod) / 86400) : $sod / 86400;
	$rdn += $doff;
	$sod -= 86400*$doff;
	return [$rdn, $sod];

lib/App/olson.pm  view on Meta::CPAN

#
# querying timezones
#

my %translate_exception = (
	"zone disuse" => "!",
	"missing data" => "?",
	"offset change" => "~",
);

sub _handle_exception($$$) {
	my($val, $expect_rx, $err) = @_;
	if($err eq "") {
		return $val;
	} elsif($err =~ /\A
		$expect_rx\ in\ the\ [!-~]+\ timezone
		\ due\ to\ (offset\ change|zone\ disuse|missing\ data)\b
	/x) {
		return $translate_exception{$1};
	} else {
		die $err;

lib/App/olson.pm  view on Meta::CPAN

{
	package App::olson::UtcDateTime;
	sub new {
		my($class, $rdns) = @_;
		return bless({ rdn => $rdns->[0], sod => $rdns->[1] }, $class);
	}
	sub utc_rd_values { ($_[0]->{rdn}, $_[0]->{sod}, 0) }
}

sub _handle_forward_exception($$) {
	return _handle_exception($_[0],
		qr/time [-:TZ0-9]+ is not represented/, $_[1]);
}

{
	package App::olson::LocalDateTime;
	sub new {
		my($class, $rdns) = @_;
		return bless({ rdn => $rdns->[0], sod => $rdns->[1] }, $class);
	}
	sub local_rd_values { ($_[0]->{rdn}, $_[0]->{sod}, 0) }
}

sub _handle_backward_exception($$) {
	return _handle_exception($_[0],
		qr/local time [-:T0-9]+ does not exist/, $_[1]);
}

#
# data type metadata
#

our %type;

lib/App/olson.pm  view on Meta::CPAN

	present => sub { $_[0] },
	present_exception_width => 5,
	present_field_width => 10,
	rx => qr/[A-Za-z]+/,
	parse => sub { ucfirst(lc($_[0])) },
	cmp => sub { $_[0] cmp $_[1] },
};

my $rdn_epoch_cjdn = 1721425;

sub _present_caltime($) {
	my($rdns) = @_;
	my($rdn, $sod) = @$rdns;
	use integer;
	return present_ymd($rdn + $rdn_epoch_cjdn).
		"T".sprintf("%02d:%02d:%02d", $sod/3600, $sod/60%60, $sod%60);
}

my $caltime_rx = qr/
	[0-9]{4}
	(?:-[0-9]{2}

lib/App/olson.pm  view on Meta::CPAN

	|
	[0-9]{4}
	(?:[0-9]{2}
	(?:[0-9]{2}
	(?:\ *(?:[Tt]\ *)?[0-9]{2}
	(?:[0-9]{2}
	(?:[0-9]{2}
	)?)?)?)?)?
/x;

sub _parse_caltime($) {
	my($txt) = @_;
	my($y, $mo, $d, $h, $mi, $s) = ($txt =~ /\A
		([0-9]{4})
		(?:.*?([0-9]{2})
		(?:.*?([0-9]{2})
		(?:.*?([0-9]{2})
		(?:.*?([0-9]{2})
		(?:.*?([0-9]{2})
		)?)?)?)?)?
	/sx);

lib/App/olson.pm  view on Meta::CPAN

	present => \&_present_caltime,
	present_exception_width => 19,
	rx => $caltime_rx,
	parse => \&_parse_caltime,
	cmp => sub { $_[0]->[0] <=> $_[1]->[0] || $_[0]->[1] <=> $_[1]->[1] },
};

my $unix_epoch_rdn = 719163;

my $now_absolute_time;
sub _now_absolute_time() {
	return $now_absolute_time ||= do {
		my $nowu = time;
		[ int($nowu/86400) + $unix_epoch_rdn, $nowu % 86400 ];
	};
}

$type{absolute_time} = {
	desc => "absolute time",
	present => sub { _present_caltime($_[0])."Z" },
	present_exception_width => 20,

lib/App/olson.pm  view on Meta::CPAN

};

$type{truth} = {
	desc => "truth value",
	present => sub { $_[0] ? "+" : "-" },
	rx => qr/[-+]/,
	parse => sub { $_[0] eq "+" ? 1 : 0 },
	cmp => sub { $_[0] <=> $_[1] },
};

sub _type_parse_from_gmatch($$) {
	my($type, $rtxt) = @_;
	my $typerx = $type->{rx} or die "can't input a @{[$type->{desc}]}\n";
	$$rtxt =~ /\G(
		[\+\-\/0-9\:A-Z_a-z]
		(?:[\ \+\-\/0-9\:A-Z_a-z]*[\+\-\/0-9\:A-Z_a-z])?
	)/xgc or die "missing value\n";
	my $valtxt = $1;
	$valtxt =~ /\A$typerx\z/ or die "malformed @{[$type->{desc}]}\n";
	return $type->{parse}->($valtxt);
}

sub _type_curry_xpresent($) {
	my($type) = @_;
	my $pew = exists($type->{present_exception_width}) ?
			$type->{present_exception_width} : 1;
	my $pfw = exists($type->{present_field_width}) ?
			$type->{present_field_width} : 0;
	return $type->{t_present} ||= sub {
		my($value) = @_;
		my $txt = _is_exception($value) ?
				$value x $pew : $type->{present}->($value);
		$txt .= " " x ($pfw - length($txt)) if $pfw > length($txt);
		return $txt;
	};
}

sub _type_curry_xcmp($) {
	my($type) = @_;
	my $cmp_normal = $type->{cmp};
	return $type->{t_cmp} ||= sub {
		my($x, $y) = @_;
		if(_is_exception($x)) {
			if(_is_exception($y)) {
				return _cmp_exception($x, $y);
			} else {
				return -1;
			}

lib/App/olson.pm  view on Meta::CPAN

	type => "calendar_time",
	cost => 11,
	get_needs => { z=>undef },
	curry_get => sub {
		my($when) = $_[0]->{"\@"};
		my $get_offs = $attrclass{offset}->{curry_get}->($_[0]);
		return sub { _caltime_offset($when, $get_offs->($_[0])) };
	},
};

sub _parse_attribute_from_gmatch($) {
	my($rtxt) = @_;
	$$rtxt =~ /\G([a-zA-Z0-9_]+)/gc or die "missing attribute name\n";
	my $classname = $1;
	my $ac = $attrclass{$classname}
		or die "no such attribute class `$classname'\n";
	my %pval;
	while($$rtxt =~ /\G *([\@]) */gc) {
		my $pkey = $1;
		die "clashing `$pkey' parameters for ".
			"@{[$ac->{desc}]} attribute\n"

lib/App/olson.pm  view on Meta::CPAN

}

my %cmp_ok = (
	"<" => sub { $_[0] < 0 },
	">" => sub { $_[0] > 0 },
	"<=" => sub { $_[0] <= 0 },
	">=" => sub { $_[0] >= 0 },
	"=" => sub { $_[0] == 0 },
);

sub _parse_criterion_from_gmatch($) {
	my($rtxt) = @_;
	my $attr = _parse_attribute_from_gmatch($rtxt);
	$$rtxt =~ /\G *(!)?([<>]=?|=|\?)/gc
		or die "syntax error in criterion\n";
	my($neg, $op) = ($1, $2);
	my $get = $attr->{xget};
	my $posxmatch;
	if($op eq "?") {
		$posxmatch = sub { !_is_exception(&$get) };
	} else {

lib/App/olson.pm  view on Meta::CPAN

		$res;
	} keys %output) {
		my $vals = $output{$_};
		my $line = join("  ", map { $presenters[$_]->($vals->[$_]) }
					@display_attrs);
		$line =~ s/ +\z//;
		print $line, "\n";
	}
};

sub run(@) {
	my $cmd = shift(@_);
	defined $cmd or die "no subcommand specified\n";
	($command{$cmd} || sub { die "unrecognised subcommand\n" })->(@_);
}

=head1 SEE ALSO

L<DateTime::TimeZone::Olson>,
L<Time::OlsonTZ::Data>,
L<olson>

t/attr.t  view on Meta::CPAN

use warnings;
use strict;

use Params::Classify qw(is_ref);
use Test::More tests => 33;

BEGIN { use_ok "App::olson"; }

sub pa($) {
	my($txt) = @_;
	pos($txt) = undef;
	my $attr = App::olson::_parse_attribute_from_gmatch(\$txt);
	$txt =~ /\G\z/gc or die "extraneous matter after attribute\n";
	return $attr;
}

sub san($) {
	return $_[0] unless is_ref($_[0], "HASH");
	my %attr = %{$_[0]};
	foreach(keys %attr) {
		$attr{$_} = "CODE" if is_ref($attr{$_}, "CODE");
	}
	return \%attr;
}

eval { pa("") };
is $@, "missing attribute name\n";