http://www.perlmonks.org?node_id=1187995

Hello everyone! About five and a half years ago, I posted Happy unbirthday!. When I saw my fifteenth PerlMonks anniversary, I decided to write something new. However, I began to notice the new code I was writing had similar aspects to the old code I wrote for Unbirthdays, specifically the date verification subroutines I was was writing. So, I opened up Unbirthdays and took a second look. So here is the updated Unbirthdays and the new Birthday scripts.

Date::Verify

Date::Verify verifies in input and returns the appropriate value.

I am thinking on localizing this to the various countries available on Date::Calc.

package Date::Verify; use strict; use warnings; use Exporter qw(import); our @EXPORT = qw(four_digit_year month_name month_number day_number); use Data::Validate qw(is_integer is_between); use Date::Calc qw(:all); sub four_digit_year { my $year = shift; if ($year !~ /\d{4}/) { die "Sorry, please use the four digit year. Stopped"; } return $year; } sub month_name { my ($month) = @_; if (is_integer($month)) { if (is_between($month, 1, 12)) { $month = Month_to_Text($month); } else { die "Sorry, the month number you entered is invalid. Stopped"; } } else { my $decoded_month = Decode_Month($month); if ( $decoded_month ) { $month = Month_to_Text($decoded_month); } else { die "Sorry, your month name is a little short. Stopped"; } } return $month; } sub month_number { my ($month) = @_; if (is_integer($month)) { if (is_between($month, 1, 12)) { $month = $month; } else { die "Sorry, the month number you entered is invalid. Stopped"; } } else { my $decoded_month = Decode_Month($month); if ( $decoded_month ) { $month = $decoded_month; } else { die "Sorry, your month name is a little short. Stopped"; } } return $month; } sub day_number { my ($year, $month, $day) = @_; my $days = Days_in_Month($year, month_number($month)); if ($day > $days) { die "Sorry, there are only $days days in $month $year. Stopped"; } return $day; } 1;

unbirthdays.pl

I have made several changes to unbirthdays.

Usage is: unbirthdays.pl name month day year. However, if unbirthdays.pl help is used, a helpful message appears.

#!/usr/bin/perl use strict; use warnings; use Data::Validate qw(is_integer is_between); use Date::Calc qw(:all); use File::Basename; use Lingua::EN::Inflect qw(ORD); use lib 'lib'; use Date::Verify qw(four_digit_year month_name month_number day_number +); # commify, round, and pretty_number all make my numbers more readable. # commify was found in the perldocs to put commas in numbers. sub commify { local $_ = shift; 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; return $_; } my ($name, $birth_month, $birth_day, $birth_year) = @ARGV; chomp(@ARGV); if (!@ARGV || lc $name eq 'help') { my $file = basename($0); print "Please enter a single name and birthday: $file name month day + year\n"; } else { $birth_year = four_digit_year($birth_year); $birth_month = month_number($birth_month); $birth_day = day_number($birth_year, $birth_month, $birth_day); my $birth_month_name = month_name($birth_month); my $year = (localtime)[5] + 1900; my $month = (localtime)[4] + 1; my $day = (localtime)[3]; # The following counts how many birthdays there has been. # It also figures out the next year for a birthday. # I'm still working on the kinks in the next birthday. my $birthdays; my $next_year; if ($birth_month > $month) { $birthdays = $year - $birth_year - 1; $next_year = $year; } elsif ($birth_month < $month) { $birthdays = $year - $birth_year - 1; $next_year = $year + 1; } else { if ($birth_day > $day) { $birthdays = $year - $birth_year - 1; $next_year = $year; } else { $birthdays = $year - $birth_year; $next_year = $year + 1; } } my @birth = ($birth_year, $birth_month, $birth_day); my @next_bday = ($next_year, $birth_month, $birth_day); my @today = ($year, $month, $day); my $days_alive = Delta_Days(@birth,@today); my $days_til_next_bday = Delta_Days(@today,@next_bday); my $unbirthdays = $days_alive - $birthdays; my $unbirthday_text; if ($month == $birth_month && $day == $birth_day) { my $birthday = ORD($year - $birth_year); $unbirthday_text = "Happy $birthday birthday"; } elsif ($unbirthdays > 0) { my $ord_unbirthdays = commify(ORD($unbirthdays)); $unbirthday_text = "Happy $ord_unbirthdays unbirthday"; } else { $unbirthday_text = "Tomorrow is your first unbirthday"; } print "$unbirthday_text, $name! You have $days_til_next_bday days un +til your next birthday on $birth_month_name $birth_day, $next_year.\n +"; }

birthday.pl

I was writing birthday.pl when I realized I was writing similar code as was in unbirthdays.pl. This script will tell the user their tropical zodiace sign, their birth stone and flowers (flowers for the US and UK are listed), and birth day stone (based on day of the week the user was born).

This is a silly little script, but it helped me fix the previous one.

Usage is: birthday.pl name month day year. However, if birthday.pl help is used, a helpful message appears.

#!/usr/bin/perl use strict; use warnings FATAL => qw( all ); use Data::Validate qw(is_integer is_between); use Date::Calc qw(:all); use File::Basename; use String::Util qw(trim); use lib 'lib'; use Date::Verify qw(four_digit_year month_name month_number day_number +); my $month_items; my $day_stones; my $zodiac; my $inc; while (<DATA>) { chomp($_); $inc++ if (!$inc || !$_); if ( $inc == 1 && $_) { my ($month, $stone, $us_flower, $bi_flower) = split(/\|/, $_); $month = trim($month); $month_items->{$month}{stone} = trim($stone); $month_items->{$month}{flower}{US} = trim($us_flower); $month_items->{$month}{flower}{UK} = trim($bi_flower); } if ( $inc == 2 && $_ ) { my ($day, $stone) = split(/\|/, $_); $day_stones->{trim($day)} = $stone; } if ( $inc == 3 && $_ ) { my ($sign, $start_month, $start_day, $end_month, $end_day, $stone) + = split(/\|/, $_); $sign = trim($sign); $zodiac->{$sign}{name} = $sign; $zodiac->{$sign}{start_month} = trim($start_month); $zodiac->{$sign}{start_day} = $start_day; $zodiac->{$sign}{end_month} = trim($end_month); $zodiac->{$sign}{end_day} = $end_day; $zodiac->{$sign}{stone} = $stone; } } # commify, round, and pretty_number all make my numbers more readable. # commify was found in the perldocs to put commas in numbers. sub commify { local $_ = shift; 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; return $_; } sub month_stone { my ($month) = @_; $month = month_name($month); return $month_items->{$month}{stone}; } sub month_flower { my ($month, $country) = @_; $month = month_name($month); return $month_items->{$month}{flower}{$country}; } sub day_stone { my ($year, $month, $day) = @_; $month = month_number($month); my $dow = Day_of_Week($year, $month, $day); my $day_word = Day_of_Week_to_Text($dow); return $day_stones->{$day_word}; } sub sign { my ($month, $day) = @_; $month = month_name($month); my $sign_name; for my $base_sign (keys %$zodiac) { my $sign = $zodiac->{$base_sign}; if (($month eq $sign->{start_month} && $day >= $sign->{start_day}) + || ($month eq $sign->{end_month} && $day <= $sign->{end_day})) { $sign_name = $sign->{name}; } } return $sign_name; } sub sign_stone { my ($sign) = @_; return $zodiac->{$sign}{stone}; } my ($name, $birth_month, $birth_day, $birth_year) = @ARGV; chomp(@ARGV); if (!@ARGV) { my $file = basename($0); print "Please enter a single name and birthday ($file name month day + year).\n"; } else { $birth_year = four_digit_year($birth_year); $birth_month = month_name($birth_month); $birth_day = day_number($birth_year, $birth_month, $birth_day); my $birthday = "$birth_month $birth_day, $birth_year"; my $sign_name = sign($birth_month, $birth_day); $birthday .= " ($sign_name)" if $sign_name; my $month_stone = month_stone($birth_month); my $month_flower_US = month_flower($birth_month, 'US'); my $month_flower_UK = month_flower($birth_month, 'UK'); my $day_stone = day_stone($birth_year, $birth_month, $birth_day); my $sign_stone = sign_stone($sign_name); print "Birthday: $birthday\n"; print "Birth stone: $month_stone\n"; print "Birth flower (US): $month_flower_US\n"; print "Birth flower (UK): $month_flower_UK\n"; print "Birthday stone: $day_stone\n"; print "Sign stone: $sign_stone\n" if $sign_stone; } __DATA__ January |garnet |carnation or snowdrop |carnation February |amethyst |primrose |violet or iris March |aquamarine|daffodil |daffodil April |diamond |sweat pea |sweat pea or dais +y May |emerald |hawthorne or lily of the valley|lily of the valle +y June |pearl |rose or honeysuckle |rose July |ruby |water lily or delphinium |larkspur August |peridot |poppy or gladiolus |gladiolus September|sapphire |morning glory or aster |aster or forget-m +e-not October |opal |calendula or marigold |marigold November |topaz |chrysanthemum or peony |chrysanthemum December |turquoise |holly or Narcissus |pionsetta Sunday |topaz or diamond Monday |pearl or crystal Tuesday |ruby or emerald Wednesday|amethyst or lodestone Thursday |sapphire or carnelian Friday |emerald or cat's eye Saturday |turquiose or diamond Capricorn |December |22|January |20|ruby Aquarius |January |21|February |19|garnet Pisces |February |20|March |20|amethyst Aries |March |21|April |20|bloodstone Taurus |April |21|May |21|sapphire Gemini |May |22|June |21|agate Cancer |June |22|July |22|emerald Leo |July |23|August |22|onyx Virgo |August |23|September|23|carnelian Libra |September|24|October |23|chrysolite Scorpio |October |24|November |22|beryl Sagittarius|November |23|December |21|topaz
In closing

I know these scripts probably still need work. I just hope you find them fun, or at least interesting.

No matter how hysterical I get, my problems are not time sensitive. So, relax, have a cookie, and a very nice day!
Lady Aleena

Replies are listed 'Best First'.
Re: Happy unbirthday redux! and other birthday stuff
by Lady_Aleena (Curate) on May 18, 2017 at 09:39 UTC

    I have decided to burst the subroutines from birthday into separate modules. It may be overkill, but I was inspired.

    Date::Birth::Stone

    Date::Birth::Flower

    Date::Birth::DayStone;

    Zodiac::Stone

    And all of the above changes birthday.pl to the following:

    This was a fun exercise.

    No matter how hysterical I get, my problems are not time sensitive. So, relax, have a cookie, and a very nice day!
    Lady Aleena

      Nice effort.

      I would highly recommend using @EXPORT_OK as opposed to @EXPORT. The latter forces the sub names into the caller's namespace. Even though you only have a single sub in most cases, it's still nicer to not pollute a namespace automatically:

      our @EXPORT_OK = qw( sub_one sub_two sub_three ); our %EXPORT_TAGS; $EXPORT_TAGS{all} = [@EXPORT_OK];

      Now, you can do:

      use My::Module qw(sub_one sub_three);

      ...or even:

      use My::Module qw(:all);

      ...which will import all @EXPORT_OK listed subs.