Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

Happy unbirthday redux! and other birthday stuff

by Lady_Aleena (Priest)
on Apr 15, 2017 at 05:34 UTC ( [id://1187995]=CUFP: print w/replies, xml ) Need Help??

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.

  • four_digit_year verifies the user input a four digit year. Usage: four_digit_year($year)
  • month_name verifies the mount input is correct (such as inputting 13 as a month or the too short Ju). It returns a fully spelled out month name. Usage: month_name($month)
  • month_number verifies the same as month_name, but it returns a month number instead. Usage: month_number($month)
  • day_number verifies the day is a number and that the day exists within the month of the year. It returns the day number. Usage: day_number($year, $month, $day)

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.

  • First, I got rid of the Q&A. That became annoying to me while testing the changes I made to the script. To that end, I moved the input to the command line as @ARGV.
  • Second, the Q&A was written to recurse until the input was in the correct form, however, the script now dies if the input is not in the correct form.
  • Third, I fixed several things from the former unbirthdays thread.

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 (Priest) 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.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://1187995]
Approved by Athanasius
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others goofing around in the Monastery: (4)
As of 2024-03-28 18:28 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found