Commits

Toby Inkster  committed 01255d9

naturally formatted datetimes

  • Participants

Comments (0)

Files changed (12)

+use inc::Module::Package 'RDF:standard';
+

File lib/DateTimeX/Format/Ago.pm

+package DateTimeX::Format::Ago;
+
+use 5.010;
+use common::sense;
+use constant { FALSE => 0, TRUE => 1 };
+use utf8;
+
+BEGIN {
+	$DateTimeX::Format::Ago::AUTHORITY = 'cpan:TOBYINK';
+	$DateTimeX::Format::Ago::VERSION   = '0.001';
+}
+
+use Carp 0 qw[];
+use DateTime 0 ;
+use Scalar::Util 0 qw[blessed refaddr];
+
+our %__;
+BEGIN {
+	$__{EN} = {
+		future    => "in the future",
+		recent    => "just now",
+		years     => ["%d years ago", "a year ago"],
+		months    => ["%d months ago", "a month ago"],
+		weeks     => ["%d weeks ago", "a week ago"],
+		days      => ["%d days ago", "a day ago"],
+		hours     => ["%d hours ago", "an hour ago"],
+		minutes   => ["%d minutes ago", "a minute ago"],
+		};
+	$__{DE} = {
+		future    => "in die Zukunft",
+		recent    => "vorhin",
+		years     => ["vor %d Jahren", "vor einem Jahr"],
+		months    => ["vor %d Monaten", "vor einem Monat"],
+		weeks     => ["vor %d Wochen", "vor einer Woche"],
+		days      => ["vor %d Tagen", "vor einer Tag"],
+		hours     => ["vor %d Stunden", "vor einer Stunde"],
+		minutes   => ["vor %d Minuten", "vor einer Minute"],
+		};
+}
+
+sub new
+{
+	my ($class, %options) = @_;
+	$options{'language'} //= ($ENV{LANG} // 'en');
+	$options{'language'} =~ s/\..*$//;
+	bless \%options, $class;
+}
+
+sub parse_datetime
+{
+	Carp::croak(sprintf("%s doesn't do parsing", __PACKAGE__));
+}
+
+sub format_datetime
+{
+	my ($self, $datetime) = @_;
+	$self = $self->new unless blessed($self);
+	
+	my $now     = DateTime->now;
+	my $delta   = $now - $datetime;
+	my %strings = $self->_strings;
+	
+	return $strings{future} if $delta->is_negative;
+	
+	foreach my $unit (qw/years months weeks days hours minutes/)
+	{
+		$strings{$unit}[0] = uc "%d $unit ago"
+			unless defined $strings{$unit}[0];
+		
+		my $n = $delta->in_units($unit);
+		
+		if ($n > 0)
+		{
+			if (exists $strings{$unit}[$n]
+			and defined $strings{$unit}[$n])
+			{
+				return sprintf($strings{$unit}[$n], $n);
+			}
+			
+			return sprintf($strings{$unit}[0], $n);
+		}
+	}
+	
+	return $strings{recent};
+}
+
+sub _strings
+{
+	my ($self) = @_;
+	$self = $self->new unless blessed($self);
+	
+	my $language = uc $self->{language};
+	while (length $language)
+	{
+		return %{$__{$language}} if defined $__{$language};
+		$language =~ s/(^|[_-])([^_-]*)$//;
+	}
+	
+	Carp::croak(sprintf("%s doesn't know about language %s", __PACKAGE__, $self->{language}));
+}
+
+TRUE;
+
+__END__
+
+=head1 NAME
+
+DateTimeX::Format::Ago - I should have written this module "3 years ago"
+
+=head1 SYNOPSIS
+
+  my $then = DateTime->now->subtract(days => 3);
+  say DateTimeX::Format::Ago->format_datetime($then); # "3 days ago"
+
+=head1 DESCRIPTION
+
+Ever wished DateTime::Format::Natural had a C<format_datetime>
+method?
+
+=head2 Constructor
+
+=over
+
+=item C<< new(language => $lang) >>
+
+Creates a formatter object. If the language is ommitted, extracts it from
+C<< $ENV{LANG} >>.
+
+=back
+
+=head2 Methods
+
+=over
+
+=item C<< format_datetime($dt) >>
+
+Returns something like "3 days ago" or "just now".
+
+=item C<< parse_datetime($string) >>
+
+Croaks. Don't use this.
+
+=back
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=DateTimeX-Format-Ago>.
+
+I'm actively seeking translations - only have English and German so far.
+Feel free to attach patches for other languages as bug reports.
+
+German translations are probably dodgy, as I am not a native speaker.
+
+=head1 SEE ALSO
+
+L<DateTime>, L<DateTime::Format::Natural>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2011 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

File meta/changes.ttl

+# This file acts as the project's changelog.
+
+@prefix :        <http://usefulinc.com/ns/doap#> .
+@prefix dcs:     <http://ontologi.es/doap-changeset#> .
+@prefix dc:      <http://purl.org/dc/terms/> .
+@prefix dist:    <http://purl.org/NET/cpan-uri/dist/DateTimeX-Format-Ago/> .
+@prefix rdfs:    <http://www.w3.org/2000/01/rdf-schema#> .
+@prefix xsd:     <http://www.w3.org/2001/XMLSchema#> .
+
+dist:project :release dist:v_0-001 .
+dist:v_0-001
+	a               :Version ;
+	dc:issued       "2011-11-08"^^xsd:date ;
+	:revision       "0.001"^^xsd:string ;
+	:file-release   <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/DateTimeX-Format-Ago-0.001.tar.gz> ;
+	rdfs:label      "Initial release" .
+

File meta/doap.ttl

+# This file contains general metadata about the project.
+
+@prefix :        <http://usefulinc.com/ns/doap#> .
+@prefix dc:      <http://purl.org/dc/terms/> .
+@prefix foaf:    <http://xmlns.com/foaf/0.1/> .
+@prefix rdfs:    <http://www.w3.org/2000/01/rdf-schema#> .
+@prefix xsd:     <http://www.w3.org/2001/XMLSchema#> .
+
+<http://purl.org/NET/cpan-uri/dist/DateTimeX-Format-Ago/project>
+	a               :Project ;
+	:programming-language "Perl" ;
+	:name           "DateTimeX-Format-Ago" ;
+	:shortdesc      "I should have written this module \"3 years ago\"" ;
+	:homepage       <https://metacpan.org/release/DateTimeX-Format-Ago> ;
+	:download-page  <https://metacpan.org/release/DateTimeX-Format-Ago> ;
+	:bug-database   <http://rt.cpan.org/Dist/Display.html?Queue=DateTimeX-Format-Ago> ;
+	:created        "2011-11-08"^^xsd:date ;
+	:license        <http://dev.perl.org/licenses/> ;
+	:developer      [ a foaf:Person ; foaf:name "Toby Inkster" ; foaf:mbox <mailto:tobyink@cpan.org> ] .
+
+<http://dev.perl.org/licenses/>
+	dc:title        "the same terms as the perl 5 programming language system itself" .
+

File meta/makefile.ttl

+# This file provides instructions for packaging.
+
+@prefix : <http://purl.org/NET/cpan-uri/terms#> .
+
+<http://purl.org/NET/cpan-uri/dist/DateTimeX-Format-Ago/project>
+	:perl_version_from _:main ;
+	:version_from _:main ;
+	:readme_from _:main ;
+	:test_requires "Test::More 0.61" ;
+	:requires "Scalar::Util" , "common::sense" .
+
+_:main <http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#fileName> "lib/DateTimeX/Format/Ago.pm" .
+
+use Test::More tests => 1;
+BEGIN { use_ok('DateTimeX::Format::Ago') };
+

File t/02roundtrip-natural.t

+use Test::More;
+use DateTimeX::Format::Ago;
+
+plan skip_all => 'Need DateTime::Format::Natural'
+	unless eval 'use DateTime::Format::Natural; 1';
+
+plan tests => 13;
+my $tests = <<'TESTS';
+just now
+a minute ago
+3 minutes ago
+an hour ago
+3 hours ago
+a day ago
+3 days ago
+a week ago
+3 weeks ago
+a month ago
+3 months ago
+a year ago
+3 years ago
+TESTS
+
+my $natural = DateTime::Format::Natural->new;
+my $ago     = DateTimeX::Format::Ago->new(language => 'en-GB-oed');
+foreach my $string (split /\n/, $tests)
+{
+	next unless length $string;
+	
+	SKIP: {
+		my $dt = $natural->parse_datetime($string);
+		skip "DateTime::Format::Natural couldn't parse '$string'", 1
+			unless $natural->success;
+		
+		is($ago->format_datetime($dt), $string, "Roundtrip for '$string'");
+	};
+}

File t/03lang-en.t

+use strict;
+use DateTimeX::Format::Ago;
+use Test::More tests => 200;
+
+# Some of these tests rely on computation being carried out reasonably fast.
+# I can only see them failing on really slow and overloaded CPUs though.
+
+my $ago = DateTimeX::Format::Ago->new(language => 'EN');
+
+foreach my $unit (qw/years months weeks days hours minutes/)
+{
+	my $max = {
+		years   => 25,
+		months  => 11,
+		weeks   => 3,  # don't want to fail tests in February 2013.
+		days    => 6,  
+		hours   => 22, # don't want to fail due to daylight savings.
+		minutes => 59,
+		}->{$unit};
+
+	my $when = DateTime->now->subtract($unit => 1);
+	is($ago->format_datetime($when), {
+		'years'    => 'a year ago',
+		'months'   => 'a month ago',
+		'weeks'    => 'a week ago',
+		'days'     => 'a day ago',
+		'hours'    => 'an hour ago',
+		'minutes'  => 'a minute ago',
+		}->{$unit});
+
+	for my $n (2..$max)
+	{
+		my $when = DateTime->now->subtract($unit => $n);
+		is($ago->format_datetime($when), "$n $unit ago");
+	}
+}
+
+for my $n (1..58)
+{
+	my $when = DateTime->now->subtract(seconds => $n);
+	is($ago->format_datetime($when), "just now");
+}
+
+for my $n (62..70)
+{
+	my $when = DateTime->now->subtract(seconds => $n);
+	is($ago->format_datetime($when), "a minute ago");
+}
+
+for my $unit (qw/seconds minutes hours days weeks months years/)
+{
+	my $when = DateTime->now->add($unit => 3);
+	is($ago->format_datetime($when), "in the future");
+}
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+

File xt/02pod_coverage.t

+use Test::More;
+use Test::Pod::Coverage;
+
+my @modules = qw(DateTimeX::Format::Ago);
+pod_coverage_ok($_, "$_ is covered")
+	foreach @modules;
+done_testing(scalar @modules);
+

File xt/03meta_uptodate.t

+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok('DateTimeX-Format-Ago', 'DateTimeX::Format::Ago');
+
+use Test::EOL;
+all_perl_files_ok();