view release on metacpan or  search on metacpan

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

=head1 NAME

App::olson - query the Olson timezone database

=head1 SYNOPSIS

    olson list <criterion>... <attribute>...
    olson version

=head1 DESCRIPTION

This module implements the L<olson> command-line utility.  See L<olson>
for details of usage.

=head1 FUNCTIONS

=over

=item App::olson::run(@ARGV)

Performs the job of the L<olson> program.  The interface to this function
may change in the future.

=back

=cut

package App::olson;

{ use 5.006; }
use warnings;
use strict;

use Date::ISO8601 0.000 qw(ymd_to_cjdn present_ymd);
use DateTime::TimeZone::Olson 0.003 qw(
	olson_version olson_all_names olson_canonical_names olson_links
	olson_country_selection olson_tz
);
use DateTime::TimeZone::SystemV 0.002 ();
use DateTime::TimeZone::Tzfile 0.007 ();
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];
}

#
# 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;
	}
}

{
	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;

$type{string} = {
	desc => "string",
	present => sub { ${$_[0]} },
	present_exception_width => 5,
	cmp => sub { ${$_[0]} cmp ${$_[1]} },
};

$type{zone_name} = {
	desc => "timezone name",
	present => sub { $_[0] },
	present_exception_width => 5,
	present_field_width => 32,
	rx => qr#[\+\-0-9A-Z_a-z]+(?:/[\+\-0-9A-Z_a-z]+)*#,
	parse => sub { $_[0] },
	cmp => sub { $_[0] cmp $_[1] },
};

{ my $areas; sub _areas() { $areas ||= do {
	my %areas;
	foreach my $country (values %{olson_country_selection()}) {
		foreach my $region (values %{$country->{regions}}) {
			$areas{$1} = undef
				if $region->{timezone_name} =~ m#\A([^/]+)/#;
		}
	}
	\%areas;
} } }

$type{area_name} = {
	desc => "area name",
	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) = @_;

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

	desc => "country code",
	params => {},
	type => "country_code",
	check_value => sub {
		die "no such country code `$_[0]'\n"
			unless exists olson_country_selection()->{$_[0]};
	},
	cost => 0,
	get_needs => { c=>undef },
	curry_get => sub { sub { $_[0]->{c} } },
};

$attrclass{cn} = $attrclass{country_name} = {
	desc => "country name",
	params => {},
	type => "string",
	cost => 1,
	get_needs => { c=>undef },
	curry_get => sub {
		my $sel = olson_country_selection();
		return sub { \$sel->{$_[0]->{c}}->{olson_name} };
	},
};

$attrclass{rd} = $attrclass{region_description} = {
	desc => "region description",
	params => {},
	type => "string",
	cost => 1,
	get_needs => { region=>undef },
	curry_get => sub { sub { \$_[0]->{region}->{olson_description} } },
};

$attrclass{k} = $attrclass{canonical_zone_name} = {
	desc => "canonical timezone name",
	params => {},
	type => "zone_name",
	check_value => sub {
		die "no such canonical timezone `$_[0]'\n"
			unless exists olson_canonical_names()->{$_[0]};
	},
	cost => 1,
	get_needs => { z=>undef },
	curry_get => sub {
		my $links = olson_links();
		return sub {
			my $z = $_[0]->{z};
			return exists($links->{$z}) ? $links->{$z} : $z;
		};
	},
};

$attrclass{o} = $attrclass{offset} = {
	desc => "offset",
	params => { "\@" => "absolute_time" },
	type => "offset",
	cost => 10,
	get_needs => { z=>undef },
	curry_get => sub {
		my($when) = $_[0]->{"\@"};
		my $whendt = App::olson::UtcDateTime->new($when);
		return sub {
			my $zone = olson_tz($_[0]->{z});
			return _handle_forward_exception(eval {
				local $SIG{__DIE__};
				0+$zone->offset_for_datetime($whendt);
			}, $@);
		};
	},
};

$attrclass{i} = $attrclass{initialism} = {
	desc => "initialism",
	params => { "\@" => "absolute_time" },
	type => "initialism",
	cost => 10,
	get_needs => { z=>undef },
	curry_get => sub {
		my($when) = $_[0]->{"\@"};
		my $whendt = App::olson::UtcDateTime->new($when);
		return sub {
			my $zone = olson_tz($_[0]->{z});
			return _handle_forward_exception(eval {
				local $SIG{__DIE__};
				$zone->short_name_for_datetime($whendt);
			}, $@);
		};
	},
};

$attrclass{d} = $attrclass{dst_status} = {
	desc => "DST status",
	params => { "\@" => "absolute_time" },
	type => "truth",
	cost => 10,
	get_needs => { z=>undef },
	curry_get => sub {
		my($when) = $_[0]->{"\@"};
		my $whendt = App::olson::UtcDateTime->new($when);
		return sub {
			my $zone = olson_tz($_[0]->{z});
			return _handle_forward_exception(eval {
				local $SIG{__DIE__};
				$zone->is_dst_for_datetime($whendt) ? 1 : 0;
			}, $@);
		};
	},
};

$attrclass{t} = $attrclass{local_time} = {
	desc => "local time",
	params => { "\@" => "absolute_time" },
	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"
				if exists $pval{$pkey};
		my $ptype = $ac->{params}->{$pkey}
			or die "unwanted `$pkey' parameter for ".
				"@{[$ac->{desc}]} attribute\n";
		$pval{$pkey} = _type_parse_from_gmatch($type{$ptype}, $rtxt);
	}
	foreach my $pkey (keys %{$ac->{params}}) {
		die "@{[$ac->{desc}]} attribute needs a `$pkey' parameter\n"
			unless exists $pval{$pkey};
	}
	my $get = $ac->{curry_get}->(\%pval);
	return {
		type => $type{$ac->{type}},
		check_value => $ac->{check_value} || sub { },
		cost => $ac->{cost},
		get_needs => $ac->{get_needs},
		xget => sub {
			foreach(keys %{$ac->{get_needs}}) {
				return "!" unless exists $_[0]->{$_};
			}
			return &$get;
		},
	};
}

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 {
		my $cmpok = $cmp_ok{$op};
		$$rtxt =~ /\G +/gc;
		my $cmpval = _type_parse_from_gmatch($attr->{type}, $rtxt);
		$attr->{check_value}->($cmpval);
		my $cmp = $attr->{type}->{cmp};
		$posxmatch = sub {
			my $val = &$get;
			return 0 if _is_exception($val);
			return $cmpok->($cmp->($val, $cmpval));
		};
	}
	return {
		cost => $attr->{cost},
		match_needs => $attr->{get_needs},
		xmatch => $neg ? sub { !&$posxmatch } : $posxmatch,
	};
}

#
# top-level commands
#

my %command;

$command{version} = sub {
	die "bad arguments\n" if @_;
	print "modules:\n";
	foreach my $mod (qw(
		App::olson
		DateTime::TimeZone::Olson
		DateTime::TimeZone::SystemV
		DateTime::TimeZone::Tzfile
		Time::OlsonTZ::Data
	)) {
		no strict "refs";
		print "    $mod ${qq(${mod}::VERSION)}\n";
	}
	print "Olson database: @{[olson_version]}\n";
};

$command{list} = sub {
	my(@criteria, @output_attrs, @display_attrs, @sort_attrs);
	foreach my $arg (@_) {
		if($arg =~ /\A *[-+]/) {
			pos($arg) = undef;
			$arg =~ /\G *([-+]) */gc;
			my $neg = $1 eq "-";
			my $attr = _parse_attribute_from_gmatch(\$arg);
			$arg =~ /\G *\z/gc
				or die "syntax error in sort directive\n";
			push @output_attrs, $attr;
			push @sort_attrs, { index=>$#output_attrs, neg=>$neg };
			next;
		}
		if($arg =~ /\A *[0-9A-Z_a-z]/) {
			pos($arg) = undef;
			$arg =~ /\G +/gc;
			my $attr = _parse_attribute_from_gmatch(\$arg);
			if($arg =~ /\G *\z/gc) {
				push @output_attrs, $attr;
				push @display_attrs, $#output_attrs;
				next;
			}
		}
		pos($arg) = undef;
		$arg =~ /\G +/gc;
		my $crit = _parse_criterion_from_gmatch(\$arg);
		$arg =~ /\G *\z/gc or die "syntax error in criterion\n";
		push @criteria, $crit;
	}
	die "must list at least one attribute\n" unless @display_attrs;
	push @sort_attrs, map { { index=>$_, neg=>0 } } @display_attrs;
	@criteria = sort { $a->{cost} <=> $b->{cost} } @criteria;
	my %need = (
		(map { %{$_->{match_needs}} } @criteria),
		(map { %{$_->{get_needs}} } @output_attrs),
	);
	my @joined;
	if(exists($need{region}) || exists($need{c})) {
		# Fully joining zones, regions, and countries is pretty
		# cheap, so don't try to be cleverer about doing less
		# join work.
		my %zleft = %{olson_all_names()};
		my $sel = olson_country_selection();
		foreach(sort keys %$sel) {
			my $csel = $sel->{$_};
			if(keys(%{$csel->{regions}}) == 0) {
				push @joined, { c => $csel->{alpha2_code} };
				next;
			}
			foreach(sort keys %{$csel->{regions}}) {
				my $reg = $csel->{regions}->{$_};
				my $zname = $reg->{timezone_name};
				push @joined, {
					c => $csel->{alpha2_code},
					region => $reg,
					z => $zname,
				};
				delete $zleft{$zname};
			}
		}
		push @joined, {z=>$_} foreach sort keys %zleft;
	} else {
		@joined = map { {z=>$_} } sort keys %{olson_all_names()};
	}
	my @presenters =
		map { _type_curry_xpresent($_->{type}) } @output_attrs;
	my @sorters = map { _type_curry_xcmp($_->{type}) } @output_attrs;
	my %output;
	foreach my $item (@joined) {
		next unless _all { $_->{xmatch}->($item) } @criteria;
		my @vals = map { $_->{xget}->($item) } @output_attrs;
		next if _all { _is_exception($_) && $_ eq "!" } @vals;
		$output{
			join("\0", map { $presenters[$_]->($vals[$_]) }
					0..$#output_attrs)
		} = \@vals;
	}
	foreach(sort {
		my $av = $output{$a};
		my $bv = $output{$b};
		my $res = 0;
		foreach(@sort_attrs) {
			$res = $sorters[$_->{index}]
				->($av->[$_->{index}], $bv->[$_->{index}]);
			$res = -$res if $_->{neg};
			last if $res != 0;
		}
		$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>

=head1 AUTHOR

Andrew Main (Zefram) <zefram@fysh.org>

=head1 COPYRIGHT

Copyright (C) 2012 Andrew Main (Zefram) <zefram@fysh.org>

=head1 LICENSE

This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;