[adelaide.pm] next perl mongers

Andrew Kirkpatrick andrew.kirkpatrick at adelaide.edu.au
Tue Feb 23 00:12:08 PST 2010


I like thursdays. That is all. Or not - the following allows for votes 
as integers representing the day of month, by taking the last mode of 
the sample as the winner. Without votes, it tries for the same day and 
week of month in the following month. Error handling and removing or 
supporting time of day is left as an exercise for the reader.

#!/usr/bin/perl

package AdelaidePM;

use Moose;
use DateTime;
use Date::Parse;
use Statistics::Descriptive;

has votes         => (isa => 'ArrayRef[Int]', is => 'rw',
                       default => sub { [] });
has last_date     => (isa => 'DateTime', is => 'rw');
has day_of_week   => (isa => 'Int', is => 'rw');
has week_of_month => (isa => 'Int', is => 'rw');

around 'last_date' => sub {
     my ($orig, $self) = splice @_, 0, 2;
     my $result;
     if (@_) {
         my $date = shift;
         unless (eval { $date->isa('DateTime') }) {
             $date = DateTime->from_epoch( epoch => str2time($date) );
             $date->set_time_zone('Australia/Adelaide');
         }
         $result = $self->$orig($date);
         $self->day_of_week($date->day_of_week);
         $self->week_of_month($date->week_of_month);
     } else {
         $result = $self->$orig;
     }
     return $result;
};

sub next_date {
     my $self = shift;
     $self->add_votes(@_) if @_;

     my $next_date = $self->last_date->clone;
     $next_date->subtract(days => $next_date->day - 1)->add(months => 1);
     my $next_month = $next_date->month;

     my $votes = $self->votes;
     if (@$votes) {
         my $stats = Statistics::Descriptive::Full->new;
         $stats->add_data(@$votes);
         my $mode = $stats->mode;
         $next_date->add(days => $mode - 1);

     } else {
         my ($dow, $wom) = map $self->$_, qw(day_of_week week_of_month);
         while ($next_date->day_of_week != $dow ||
                $next_date->week_of_month != $wom) {

             $next_date->add(days => 1);
             last if $next_date->month != $next_month;
         }
     }
     die "We're all DOOMED" if $next_date->month != $next_month;
     return $next_date;
}

sub add_votes {
   my ($self) = shift;
   push @{$self->votes}, @_;
}


package main;

use Getopt::Long;

my %opt = (
            last_date => "2010-02-23",
            votes     => [],
           );

GetOptions(\%opt, qw(last_date=s votes=i@)) or exit 1;
push @{$opt{votes}}, grep /^\d{1,2}$/, @ARGV;

my $pm = AdelaidePM->new;
$pm->votes($opt{votes});
$pm->last_date($opt{last_date});

print $pm->next_date, "\n";

# ~/dev/perl$ ./adelaide_pm.pl --last_date 2010-4-13 7 7 13 24 24
# 2010-05-24T00:00:00

-- 
Andrew Kirkpatrick
Web Application Programmer, Online Media Team
Department of Marketing and Strategic Communications
The University of Adelaide, CRICOS Provider Number 00123M
Work Requests: http://www.adelaide.edu.au/webguide/request.html

PHP is a minor evil perpetrated and created by incompetent amateurs,
whereas Perl is a great and insidious evil, perpetrated by skilled
but perverted professionals.

  -- Jon Ribbens

-----------------------------------------------------------
This email message is intended only for the addressee(s)
and contains information that may be confidential and/or
copyright.  If you are not the intended recipient please
notify the sender by reply email and immediately delete
this email. Use, disclosure or reproduction of this email
by anyone other than the intended recipient(s) is strictly
prohibited. No representation is made that this email or
any attachments are free of viruses. Virus scanning is
recommended and is the responsibility of the recipient.


More information about the Adelaide-pm mailing list