view release on metacpan or  search on metacpan

scripts/build_tz_database.pl  view on Meta::CPAN

        if( @versions )
        {
            my( $latest ) = sort {
                my( $ya, $la ) = $a =~ /^(\d{4})([a-z]+)$/;
                my( $yb, $lb ) = $b =~ /^(\d{4})([a-z]+)$/;
                $yb <=> $ya || $lb cmp $la;
            } @versions;
            _message( 3, "Latest version found is '", ( $latest // 'undef' ), "'" );
            return( $latest );
        }
    }

    # Fallback: download tzdata-latest.tar.gz, read the VERSION from Makefile
    _message( 1, "  Falling back to tzdata-latest.tar.gz..." );
    my $tmp = $cache_dir->child( 'tzdata-latest.tar.gz' );
    # _download_ftp( IANA_LATEST_DATA, $tmp );
    _download_web( IANA_LATEST_DATA, $tmp );

    my $version = _version_from_tarball( $tmp );

    # Rename to versioned name in cache
    my $dest = $cache_dir->child( "tzdata${version}.tar.gz" );
    $tmp->rename( $dest ) ||
        die( "Cannot rename '$tmp' to '$dest': ", $tmp->error, "\n" );
    return( $version );
}

sub _fetch_mirror
{
    my( $url, $local ) = @_;
    require HTTP::Promise;
    my $ua = HTTP::Promise->new(
        auto_switch_https       => 1,
        ext_vary                => 1,
        max_body_in_memory_size => 102400,
        max_redirect            => 3,
        timeout                 => 10,
        use_promise             => 0,
        ( $opts->{http_debug} ? ( debug => $opts->{http_debug} ) : () ),
    ) || die( "Error instantiating a HTTP::Promise object: ", HTTP::Promise->error );
    my $resp = $ua->mirror( $url => $local ) ||
        die( "Failed to get the remote file $url and cache it locally to $local: ", $ua->error );
    if( $resp->code == 304 )
    {
        _message( 2, "Local copy is already up to date (304 Not Modified)." );
    }
    elsif( $resp->is_success )
    {
        _message( 2, sprintf( "Downloaded fresh copy (HTTP %d); saved to %s",
                              $resp->code,
                              $local
                    ) );
    }
    else
    {
        _message( 2, sprintf( "Unexpected response: HTTP %d %s",
                              $resp->code,
                              $resp->message
                     ) );
    }
    my $out = $resp->decoded_content_utf8;
    return( $out ) if( defined( $out ) && length( $out ) );
    return;
}

sub _fetch_url
{
    my $url = shift( @_ );
    require HTTP::Promise;
    my $ua = HTTP::Promise->new(
        auto_switch_https       => 1,
        ext_vary                => 1,
        max_body_in_memory_size => 102400,
        max_redirect            => 3,
        timeout                 => 10,
        use_promise             => 0,
        ( $opts->{http_debug} ? ( debug => $opts->{http_debug} ) : () ),
    ) || die( "Error instantiating a HTTP::Promise object: ", HTTP::Promise->error );
    my $resp = $ua->get( $url ) ||
        die( "Error fetching remote URL $url: ", $ua->error );
    my $out = $resp->decoded_content_utf8;
    return( $out ) if( defined( $out ) && length( $out ) );
    return;
}

my %_tool_cache;
sub _has_tool
{
    my $t = shift( @_ );
    return( $_tool_cache{ $t } ) if( exists( $_tool_cache{ $t } ) );
    my $bin = which( $t );
    return( $_tool_cache{ $t } = $bin );
}

# This version triggers the warning:
# "Hexadecimal number > 0xffffffff non-portable"
# sub _i32be
# {
#     my( $s ) = @_;
# 
#     my $u = unpack( 'N', $s );
#     return( $u >= 0x80000000 ) ? $u - 0x100000000 : $u;
# }
sub _i32be
{
    my( $s ) = @_;

    return( unpack( 'l>', $s ) );
}

# sub _i64be
# {
#     my( $s ) = @_;
# 
#     my( $hi, $lo ) = unpack( 'NN', $s );
#     my $u = ( $hi * 4294967296 ) + $lo;
# 
#     return( $hi >= 0x80000000 ) ? $u - 18446744073709551616 : $u;
# }
sub _i64be
{
    my( $s ) = @_;

    if( $HAS_NATIVE_I64 )
    {
        return( unpack( 'q>', $s ) );
    }

    my( $hi, $lo ) = unpack( 'NN', $s );
    my $u = ( $hi * 4294967296 ) + $lo;

    # return( unpack( 'q>', $s ) );
    return( $hi >= 2147483648 ) ? $u - 18446744073709551616 : $u;
}

sub _load_schema
{
    my $schema_file = shift( @_ ) ||
        die( "No schema file provided." );
    my $sql = $schema_file->load_utf8 ||
        die( $schema_file->error );