File Coverage

blib/lib/EB/Utils.pm

Criterion	Covered	Total	%
statement	106	131	80.9
branch	61	96	63.5
condition	23	51	45.1
subroutine	7	15	46.6
pod	0	6	0.0
total	197	299	65.8

#! perl

# Utils.pm --
# Author          : Johan Vromans
# Created On      : Wed Sep 21 13:09:01 2005
# Last Modified By: Johan Vromans
# Last Modified On: Tue May 14 20:21:30 2013
# Update Count    : 127
# Status          : Unknown, Use with caution!

package EB::Utils;

use strict;

use base qw(Exporter);

our @EXPORT;
our @EXPORT_OK;

use Time::Local;

# We're imported by EB that exports _T. Kinda catch-22.
*_T = *EB::_T;

# These are only used by the BTW Aangifte modules.
# Note these are translated using _T where appropriate.
our @months =
      split(" ", "Jan Feb Mrt Apr Mei Jun Jul Aug Sep Okt Nov Dec");
our @month_names =
      split(" ", "Januari Februari Maart April Mei Juni Juli Augustus September Oktober November December");
our @days =
      split(" ", "Zon Maa Din Woe Don Vri Zat");
our @day_names =
      split(" ", "Zondag Maandag Dinsdag Woensdag Donderdag Vrijdag Zaterdag");

my $_i;

my %rev_months;
$_i = 1;
foreach ( @months ) {
    $rev_months{ lc $_  } = $_i;
    $rev_months{ "m$_i" } = $_i;
    $rev_months{ sprintf("m%02d", $_i) } = $_i;
    $_i++;
}

my %rev_month_names;
$_i = 1;
foreach ( @month_names ) {
    $rev_month_names{ lc $_ } = $_i++;
}

sub parse_date {
    my ($date, $default_year, $delta_d, $delta_m, $delta_y) = @_;

    # Parse a date and return it in ISO format (scalar) or
    # (YYYY,MM,DD) list context.

    my ($d, $m, $y);
    if ( $date =~ /^(\d\d\d\d)-(\d\d)-(\d\d)$/ ) {
	($y, $m, $d) = ($1, $2, $3);
    }
    elsif ( $date =~ /^(\d\d?)-(\d\d?)-(\d\d\d\d)$/ ) {
	($d, $m, $y) = ($1, $2, $3);
    }
    elsif ( $date =~ /^(\d\d?)-(\d\d?)$/ ) {
	return unless $default_year;
	($d, $m, $y) = ($1, $2, $default_year);
    }
    elsif ( $date =~ /^(\d\d?) (\w+)$/ ) {
	return unless $default_year;
	return unless $m = $rev_month_names{$2} || $rev_months{$2};
	($d, $y) = ($1, $default_year);
    }
    else {
	return;		# invalid format
    }

    # The date, as delivered, must be valid.
    my $time = eval { timelocal(0, 0, 12, $d, $m-1, $y) };
    return unless $time;	# invalid date

    # Handle deltas.
    $y += $delta_y if $delta_y;
    $m += $delta_m if $delta_m;
    while ( $m > 12 ) { $m -= 12, $y++ }
    while ( $m < 1  ) { $m += 12; $y-- }
    $delta_d += $d - 1;

    # New date, as of 1st of the month.
    $time = eval { timelocal(0, 0, 12, 1, $m-1, $y) };
    return unless $time;	# invalid date

    # Apply delta.
    $time += $delta_d * 24*60*60 if $delta_d;

    # Convert and return.
    my @tm = localtime($time);
    @tm = (1900 + $tm[5], 1 + $tm[4], $tm[3]);
    wantarray ? @tm : sprintf("%04d-%02d-%02d", @tm);
}

push( @EXPORT, qw(parse_date) );

sub parse_date_range {
    my ($range, $default_year) = @_;

    # Parse a date and return it as an array ref of two ISO formatted
    # dates.

    my ($d1, $m1, $y1, $d2, $m2, $y2);
    my $datefix;

    $range = lc($range);

    # 2004-03-04 - 2004-05-06 -> [ "2004-03-04", "2004-05-06" ]
    if ( $range =~ /^(\d\d\d\d)-(\d\d)-(\d\d)\s*[-\/]\s*(\d\d\d\d)-(\d\d)-(\d\d)$/ ) {
	($y1, $m1, $d1, $y2, $m2, $d2) = ($1, $2, $3, $4, $5, $6);
    }
    # 2004-03-04/05-06 -> [ "2004-03-04", "2004-05-06" ]
    elsif ( $range =~ /^(\d\d\d\d)-(\d\d)-(\d\d)\s*\/\s*(\d\d)-(\d\d)$/ ) {
	($y1, $m1, $d1, $y2, $m2, $d2) = ($1, $2, $3, $1, $4, $5);
    }
    # 2004-03-04/06 -> [ "2004-03-04", "2004-03-06" ]
    elsif ( $range =~ /^(\d\d\d\d)-(\d\d)-(\d\d)\s*\/\s*(\d\d)$/ ) {
	($y1, $m1, $d1, $y2, $m2, $d2) = ($1, $2, $3, $1, $2, $4);
    }
    # 03-04-2004 - 05-06-2004 -> [ "2004-04-03", "2004-06-05" ]
    elsif ( $range =~ /^(\d\d)-(\d\d)-(\d\d\d\d)\s*-\s*(\d\d)-(\d\d)-(\d\d\d\d)$/ ) {
	($d1, $m1, $y1, $d2, $m2, $y2) = ($1, $2, $3, $4, $5, $6);
    }
    # 03-04 - 05-06 -> [ "2004-04-03", "2004-06-25" ]
    elsif ( $range =~ /^(\d\d)-(\d\d)\s*-\s*(\d\d)-(\d\d)$/ ) {
	return unless $default_year;
	($d1, $m1, $y1, $d2, $m2, $y2) = ($1, $2, $default_year, $3, $4, $default_year);
    }
    # 3 april - 5 juni -> [ "2004-04-03", "2004-06-25" ]
    # 3 april - 5 juni 2004 -> [ "2004-04-03", "2004-06-25" ]
    elsif ( $range =~ /^(\d+)\s+(\w+)\s*-\s*(\d+)\s+(\w+)(?:\s+(\d{4}))?$/ ) {
	return unless $default_year;
	return unless $m1 = $rev_month_names{$2} || $rev_months{$2};
	return unless $m2 = $rev_month_names{$4} || $rev_months{$4};
	$d1 = $1; $d2 = $3;
	$y1 = $y2 = $5 || $default_year;
    }
    # 3 april 2004 - 5 juni 2004 -> [ "2004-04-03", "2004-06-25" ]
    elsif ( $range =~ /^(\d+)\s+(\w+)\s+(\d{4})\s*-\s*(\d+)\s+(\w+)\s+(\d{4})$/ ) {
	return unless $m1 = $rev_month_names{$2} || $rev_months{$2};
	return unless $m2 = $rev_month_names{$5} || $rev_months{$5};
	$d1 = $1; $d2 = $4;
	$y1 = $3; $y2 = $6;
    }
    # april - juni -> [ "2004-04-01", "2004-06-30" ]
    # april - juni 2004 -> [ "2004-04-01", "2004-06-30" ]
    elsif ( $range =~ /^(\w+)\s*-\s*(\w+)(?:\s+(\d{4}))?$/ ) {
	return unless $default_year;
	return unless $m1 = $rev_month_names{$1} || $rev_months{$1};
	return unless $m2 = $rev_month_names{$2} || $rev_months{$2};
	$d1 = 1; $d2 = -1;
	$y1 = $y2 = $3 || $default_year;
    }
    # 2004          -> [ "2004-01-01", "2004-12-31" ]
    elsif ( $range =~ /^(\d{4})$/ ) {
	$d1 = 1; $d2 = -1; $m1 = 1; $m2 = 12; $y1 = $y2 = $1;
    }
    # k2 -> [ "2004-04-01", "2004-06-30" ]
    # k2 2004 -> [ "2004-04-01", "2004-06-30" ]
    elsif ( $range =~ /^[kq](\d+)(?:\s+(\d{4}))?$/ ) {
	return unless $2||$default_year;
	return unless $1 >= 1 && $1 <= 4;
	$m1 = 3 * $1 - 2;
	$m2 = $m1 + 2;
	$d1 = 1; $d2 = -1; $y1 = $y2 = $2 || $default_year;
    }
    # jaar          -> [ "2004-01-01", "2004-12-31" ]
    elsif ( $range eq lc(EB::_T("jaar")) || $range eq "jaar" ) {
	return unless $default_year;
	$d1 = 1; $d2 = -1; $m1 = 1; $m2 = 12; $y1 = $y2 = $default_year;
    }
    # apr | april   -> [ "2004-04-01", "2004-04-30" ]
    # apr 2004      -> [ "2004-04-01", "2004-04-30" ]
    elsif ( $range =~ /^(\w+)(?:\s+(\d{4}))?$/ ) {
	return unless $2||$default_year;
	return unless $m1 = $m2 = $rev_month_names{$1} || $rev_months{$1};
	$d1 = 1; $d2 = -1;
	$y1 = $y2 = $2 || $default_year;
    }
    else {
	return;		# unrecognizable format
    }

    if ( $d2 < 0 ) {
	$datefix = 24 * 60 * 60;
	$d2 = 1;
	$m2 = 1, $y2++ if ++$m2 > 12;
    }

    my $time1 = eval { timelocal(0, 0, 12, $d1, $m1-1, $y1) };
    return unless $time1;	# invalid date
    my $time2 = eval { timelocal(0, 0, 12, $d2, $m2-1, $y2) };
    return unless $time2;	# invalid date
    $time2 -= $datefix if $datefix;

    my @tm = localtime($time1);
    my @tm1 = (1900 + $tm[5], 1 + $tm[4], $tm[3]);
    @tm = localtime($time2);
    my @tm2 = (1900 + $tm[5], 1 + $tm[4], $tm[3]);
    [ sprintf("%04d-%02d-%02d", @tm1),
      sprintf("%04d-%02d-%02d", @tm2) ]
}

push( @EXPORT, qw(parse_date_range) );

sub iso8601date {
    my ($time) = shift || time;
    my @tm = localtime($time);
    sprintf("%04d-%02d-%02d", 1900+$tm[5], 1+$tm[4], $tm[3]);
}

push( @EXPORT, qw(iso8601date) );

sub min { $_[0] < $_[1] ? $_[0] : $_[1] }
sub max { $_[0] > $_[1] ? $_[0] : $_[1] }

push( @EXPORT, qw(min max) );

# Locale / Gettext.
# Variable expansion. See GNU gettext for details.
sub __expand($%) {
    my ($t, %args) = @_;
    my $re = join('|', map { quotemeta($_) } keys(%args));
    $t =~ s/\{($re)\}/defined($args{$1}) ? $args{$1} : "{$1}"/ge;
    $t;
}

# Translation w/ variables.
sub __x($@) {
    my ($t, %vars) = @_;
    __expand(_T($t), %vars);
}

# Translation w/ singular/plural handling.
sub __n($$$) {
    my ($sing, $plur, $n) = @_;
    _T($n == 1 ? $sing : $plur);
}

# Translation w/ singular/plural handling and variables.
sub __nx($$$@) {
    my ($sing, $plur, $n, %vars) = @_;
    __expand(__n($sing, $plur, $n), %vars);
}

# Make __xn a synonym for __nx.
*__xn = \&__nx;

# And the dummy...
sub N__($) { $_[0] };

# This is for context sensitive translations, where e.g., cmd:btw
# translates to cmd:vat and we deliver need the part after the colon.
sub __xt {
    my $t = _T($_[0]);
    $t =~ s/^.*://;
    $t;
}

# Same, without translating.
# Basically, __xt is __XN(_T($_[0])).
sub __XN {
    my $t = $_[0];
    $t =~ s/^.*://;
    $t;
}

push( @EXPORT, qw( __x __n __nx __xn N__ __xt __XN )  );

# ... more to come ...

@EXPORT_OK = @EXPORT;

1;