The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl

use strict;
use warnings;

use lib './lib';

# Hack so loading DateTime.pm doesn't blow up
BEGIN { $DateTime::TimeZone::VERSION = '1.24' }

use Data::Dumper;
use DateTime;
use DateTime::TimeZone::OlsonDB;
use File::Copy;
use File::Find::Rule;
use File::Path;
use File::Spec;
use Getopt::Long;
use List::AllUtils qw( max );
use Locale::Country 3.11 qw( code2country );

$Data::Dumper::Indent   = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Terse    = 1;

my $VERSION = "0.07";

my $INFINITY = 100**100**100;

my %opts;
GetOptions(
    'dir:s'     => \$opts{dir},
    'clean'     => \$opts{clean},
    'version:s' => \$opts{version},
    'old'       => \$opts{old},
    'file:s'    => \$opts{file},
    'name:s'    => \$opts{name},
    'debug'     => \$opts{debug},
    'help'      => \$opts{help},
);

$opts{help} = 1
    unless defined $opts{dir} && -d $opts{dir};

$opts{help} = 1
    unless defined $opts{version} || $opts{file} || $opts{name};

$opts{version} ||= 'test';

if ( $opts{help} ) {
    print <<'EOF';

This script parses the Olson time zone database files and turns them into a
set of Perl modules.  It also generates the DateTime::TimeZone::Catalog
module, which contains a list of all the available time zone names.

By default, it looks for files named africa, antarctica, asia, australasia,
europe, northamerica, pacificnew, southamerica, and backward.  All other files
are ignored.

It takes the following arguments:

  --dir      A directory containing Olson db files.

  --version  The version of the Olson data files being used.
             Required unless one of the debugging options is given.

  --clean    Remove old generated modules (which may not be valid with
             the latest Olson database)

  --file     Parse just the file with the given name.  For debugging.

  --name     Only create the specified time zone.  For debugging.

  --old      Also look for files named etcetera, factory, and systemv

  --debug    Turn on debugging in Olson parser

  --help     What you are reading

If the --file or --name options are specified, the DateTime::TimeZone::Catalog
module will not be generated.

EOF

    exit;
}

clean() if $opts{clean};

my @files;

if ( $opts{file} ) {
    @files = $opts{file};
}
else {
    @files = qw( africa antarctica asia australasia
        europe northamerica pacificnew
        southamerica backward
    );

    push @files, qw( etcetera factory systemv )
        if $opts{old};
}

my ( @zones, %categories, %links );

my $autogen_warning = <<"EOF";
# This file is auto-generated by the Perl DateTime Suite time zone
# code generator ($VERSION) This code generator comes with the
# DateTime::TimeZone module distribution in the tools/ directory
EOF

parse_file($_) for sort @files;

exit if $opts{name};

clean_links();

make_catalog_pm();

sub clean {
    for my $f (
        File::Find::Rule->file->name('*.pm')
        ->grep('This file is auto-generated')->in('lib'),
        File::Find::Rule->file->name('zd*.t')->in('t')
        ) {
        unlink $f or die "Cannot unlink $f: $!";
    }
}

sub parse_file {
    my $file = File::Spec->catfile( $opts{dir}, shift );

    die "No such file $file\n" unless -e $file;

    print "Now parsing $file\n";

    $DateTime::TimeZone::OlsonDB::DEBUG = 1
        if $opts{debug};

    my $odb = DateTime::TimeZone::OlsonDB->new;

    $odb->parse_file($file);

    %links = ( %links, $odb->links );

    foreach my $zone_name ( sort $odb->zone_names ) {
        if ( $opts{name} ) {
            next unless $zone_name eq $opts{name};
        }
        print "  creating zone $zone_name\n";

        push @zones, $zone_name;

        my $name;
        my @dir;
        if ( $zone_name =~ m{/} ) {
            my $category;
            ( $category, $name ) = split /\//, $zone_name, 2;
            push @{ $categories{$category} }, $name;

            ( $dir[0] = $category ) =~ tr/-/_/;
        }
        else {
            $name = $zone_name;
        }

        ( my $outfile1 = $name ) =~ tr/-/_/;

        ( my $mod_name = $zone_name ) =~ s/\//::/g;
        $mod_name =~ tr/-/_/;

        my $zone     = $odb->zone($zone_name);
        my $max_year = max(
            (localtime)[5] + 1910,
            $zone->last_rules_year($odb),
        );

        $zone = $odb->expanded_zone(
            name           => $zone_name,
            expand_to_year => $max_year,
        );

        my $spans = serialize_spans( zone_as_spans($zone) );

        $spans =~ s/-inf/DateTime::TimeZone::NEG_INFINITY/g;
        $spans =~ s/inf/DateTime::TimeZone::INFINITY/g;

        $spans =~ s/('(?:start|end)_date'\s+=>\s+)'(\d+)'/$1$2/g;

        my $generator = zone_generator($zone);

        my $has_dst_changes = grep { $_->is_dst } $zone->sorted_changes;

        my $from = "Generated from $file.";
        $from .= "  Olson data version $opts{version}"
            if defined $opts{version};

        # Helps avoid mis indexing on (meta)cpan
        my $pkg_keyword = 'package';

        my $body = <<"EOF";
$autogen_warning
#
# $from
#
# Do not edit this file directly.
#
$pkg_keyword DateTime::TimeZone::$mod_name;

use strict;

use Class::Singleton 1.03;
use DateTime::TimeZone;
use DateTime::TimeZone::OlsonDB;

\@DateTime::TimeZone::${mod_name}::ISA = ( 'Class::Singleton', 'DateTime::TimeZone' );

my \$spans =
$spans;

sub olson_version { '$opts{version}' }

sub has_dst_changes { $has_dst_changes }

sub _max_year { $max_year }

sub _new_instance
{
    return shift->_init( \@_, spans => \$spans );
}

$generator

1;

EOF

        my @name_pieces = split /\//, $outfile1;
        my $filename = ( pop @name_pieces ) . '.pm';

        my $outdir = File::Spec->catdir(
            qw( lib DateTime TimeZone ),
            @dir, @name_pieces
        );

        mkpath( $outdir, 1, 0755 );

        my $outfile2 = File::Spec->catfile( $outdir, $filename );

        open my $fh, ">$outfile2" or die "Cannot write to $outfile2: $!";
        print $fh $body or die "Cannot write to $outfile2: $!";
        close $fh or die "Cannot write to $outfile2: $!";
    }
}

sub zone_as_spans {
    my $zone = shift;

    my @spans;

    my @changes = $zone->sorted_changes;

    for ( my $x = 1; $x < @changes; $x++ ) {
        my $last_total_offset
            = $x > 1 ? $changes[ $x - 2 ]->total_offset : undef;

        my $span = DateTime::TimeZone::OlsonDB::Change::two_changes_as_span(
            @changes[ $x - 1, $x ], $last_total_offset );

        push @spans, $span;

        if ( @spans > 2 ) {
            die "Gap in UTC end/start datetime for " . $zone->name
                unless $spans[-2]{utc_end} == $spans[-1]{utc_start};
        }
    }

    unless ( $zone->infinite_rules ) {
        my $last_change = $changes[-1];

        my $last_observance = $last_change->observance;

        if ( $last_change->utc_start_datetime ) {
            push @spans, {
                utc_start =>
                    $last_change->utc_start_datetime->utc_rd_as_seconds,
                utc_end => $INFINITY,
                local_start =>
                    $last_change->local_start_datetime->utc_rd_as_seconds,
                local_end  => $INFINITY,
                short_name => $last_change->short_name,
                offset     => $last_change->total_offset,
                is_dst     => $last_change->is_dst,
                };
        }

        # This happens with zones that have only one rule and no real changes (Pacific/Johnston)
        else {
            my $utc_start = @spans ? $spans[-1]{utc_end} : -1 * $INFINITY;

            push @spans, {
                utc_start   => $utc_start,
                utc_end     => $INFINITY,
                local_start => $utc_start - $last_observance->total_offset,
                local_end   => $INFINITY,
                short_name  => sprintf( $last_observance->format, '' ),
                offset      => $last_observance->total_offset,
                is_dst      => 0,
                };
        }
    }

    return \@spans;
}

sub serialize_spans {
    my $spans = shift;

    my $string = "[\n";
    $string .= join "\n", map { serialize_span($_) } @$spans;
    $string .= "\n]";

    return $string;
}

sub serialize_span {
    my $span = shift;

    # must correspond to constants in DT::TZ, and short_name is always last
    my $string = "    [\n";
    for my $key (qw( utc_start utc_end local_start local_end )) {
        my $comment = sprintf( '# %12s %s', $key, _num_as_datetime( $span->{$key} ) );
        $comment =~ s/\s+$//;
        $string .= "$span->{$key}, $comment\n";
    }

    for my $key (qw( offset is_dst )) {
        $string .= "$span->{$key},\n";
    }

    $string .= "'$span->{short_name}',";
    $string .= "\n    ],";

    return $string;
}

{
    {
        package FakeCal;

        sub utc_rd_values {
            return @{ $_[0] };
        }
    }

    sub _num_as_datetime {
        my $num = shift;

        return q{} unless $num =~ /^\d+$/;

        my $days = do { use integer; $num / 86400 };
        my $secs = $num % 86400;

        my $obj = bless [ $days, $secs, 0 ], 'FakeCal';

        my $dt = DateTime->from_object( object => $obj );

        return $dt->strftime( '%Y-%m-%d %H:%M:%S (%a)' );
    }
}

sub zone_generator {
    my $zone = shift;

    return '' unless $zone->infinite_rules;

    my $generator = <<'EOF';
sub _last_offset { !OFFSET }

my $last_observance = !LAST_OBSERVANCE;
sub _last_observance { $last_observance }

my $rules = !RULES;
sub _rules { $rules }
EOF

    my $last_observance = ( $zone->sorted_changes )[-1]->observance;

    # hack to trim size of dumped object
    delete $last_observance->{utc_start_datetime}{locale};
    delete $last_observance->{local_start_datetime}{locale};
    delete $last_observance->{utc_start_datetime}{local_c};
    delete $last_observance->{local_start_datetime}{local_c};
    delete $last_observance->{rules};
    delete $last_observance->{first_rule};

    # This assumes that there is only one observance from end of
    # changes til end of time, which should be guaranteed by code in
    # OlsonDB module.
    my $offset = $last_observance->total_offset;

    my @rules = $zone->infinite_rules;

    # This is cleaner than making the above a double-quoted string
    $generator =~ s/!RULES/Dumper \@rules/eg;
    $generator =~ s/!LAST_OBSERVANCE/Dumper $last_observance/eg;
    $generator =~ s/\$VAR1->{'local_start_datetime'}{'tz'}/bless( {
      'name' => 'floating',
      'offset' => 0
    }, 'DateTime::TimeZone::Floating' )/;
    $generator =~ s/\$VAR1->{'utc_start_datetime'}{'tz'}/bless( {
      'name' => 'floating',
      'offset' => 0
    }, 'DateTime::TimeZone::Floating' )/;
    $generator =~ s/!OFFSET/$offset/g;

    return $generator;
}

sub clean_links {

    # override some links and add others
    %links = (
        %links,
        'Etc/GMT'       => 'UTC',
        'Etc/GMT+0'     => 'UTC',
        'Etc/Universal' => 'UTC',
        'Etc/UCT'       => 'UTC',
        'Etc/UTC'       => 'UTC',
        'Etc/Zulu'      => 'UTC',
        'GMT0'          => 'UTC',
        'GMT'           => 'UTC',
        'AKST9AKDT'     => 'America/Anchorage',
        'JST-9'         => 'Asia/Tokyo',
    );

    delete $links{UTC};

    # Some links resolve to other links - chase them down until they point
    # to a real zone.
    while ( my @k = grep { $links{ $links{$_} } } keys %links ) {
        for my $k (@k) {
            $links{$k} = $links{ $links{$k} };
        }
    }
}

sub make_catalog_pm {
    my $links = Dumper \%links;
    $links =~ s/{/(/;
    $links =~ s/}/)/;

    my $zones     = join "\n", map {"  $_"} sort @zones, 'UTC';;
    my $cat_names = join "\n", map {"  $_"} sort keys %categories;
    my $cat       = '';
    foreach my $c ( sort keys %categories ) {
        $cat .= qq|  '$c' => [ qw(\n|;
        $cat .= join "\n", map {"    $_"} sort @{ $categories{$c} };
        $cat .= "\n) ],\n";
    }

    my %countries = parse_zone_tab();

    # hard-code this alias per request of David Cantrell on the list.
    $countries{UK} = $countries{GB};

    my $countries = '';
    for my $c ( sort keys %countries ) {
        $countries .= qq|  '\L$c' => [ qw(\n|;

        # We explicitly do not sort these because the order in
        # zones.tab is already in a sane sort order.
        $countries .= join "\n",
            map {"    $_"} map { $_->[0] } @{ $countries{$c} };
        $countries .= "\n) ],\n";
    }

    # Helps avoid mis indexing on (meta)cpan
    my $pkg_keyword = 'package';

    my $zonecatalog = <<"EOF";
$autogen_warning
#
# Do not edit this file directly.

$pkg_keyword DateTime::TimeZone::Catalog;

use strict;

use vars qw( \@ALL \@CATEGORY_NAMES \%CATEGORIES \%ZONES_BY_COUNTRY \%LINKS );

\@ALL =
qw(
$zones
);

\@CATEGORY_NAMES =
qw(
$cat_names
);

\%CATEGORIES =
(
$cat
);

\%ZONES_BY_COUNTRY =
(
$countries
);

\%LINKS =
$links
;

sub OlsonVersion { '$opts{version}' }


1;

__END__

=head1 NAME

DateTime::TimeZone::Catalog - Provides a list of all valid time zone names

=head1 SYNOPSIS

See DateTime::TimeZone for API details.

=head1 DESCRIPTION

This module contains an enumerated list of all known system timezones,
so that applications can easily present a list of timezones.

=head1 AVAILABLE ZONES

=head2 Zones by Continent/Region

EOF

    for my $category ( sort keys %categories ) {
        $zonecatalog .= "=head3 $category\n\n";

        for my $zone ( @{ $categories{$category} } ) {
            $zonecatalog .= "  $category/$zone\n";
        }

        $zonecatalog .= "\n";
    }

    $zonecatalog .= <<'EOF';
=head2 Zones by Country

EOF

    for my $country (
        sort { lc $a->[0] cmp lc $b->[0] }
        map {
            my $country = my_code2country($_);
            warn "no country for $_\n" unless defined $country;
            [ $country, $_ ];
        } grep { $_ ne 'UK' } keys %countries
        ) {

        $zonecatalog .= "=head3 $country->[0] ($country->[1])\n\n";

        for my $zone ( @{ $countries{ $country->[1] } } ) {
            my $line = join ' - ', grep { defined } @{$zone};
            $zonecatalog .= "  $line\n";
        }

        $zonecatalog .= "\n";
    }

    $zonecatalog .= <<'EOF';
=head2 Linked Zones

A linked zone is an alias from one name to another.

EOF

    for my $from ( sort keys %links ) {
        $zonecatalog .= "  $from => $links{$from}\n";
    }

    $zonecatalog .= "\n";

    $zonecatalog .= "=cut\n";

    open my $fh, ">lib/DateTime/TimeZone/Catalog.pm" or die $!;
    print $fh $zonecatalog or die $!;
    close $fh or die $!;
}

sub parse_zone_tab {
    my $file = File::Spec->catfile( $opts{dir}, 'zone.tab' );

    open my $fh, "<$file" or die "Cannot read $file: $!";

    my %countries;
    while (<$fh>) {
        next if /^\#/;
        chomp;

        my ( $cc, undef, $tz, $desc ) = split /\t+/, $_;

        push @{ $countries{$cc} }, [ $tz, $desc ];
    }

    return %countries;
}

sub my_code2country {
    my $code = shift;

    return 'South Sudan' if $code eq 'SS';

    return code2country($code);
}