view release on metacpan or  search on metacpan

lib/Advanced/Config/Date.pm  view on Meta::CPAN

sub _check_if_good_date
{
   DBUG_ENTER_FUNC ( @_ );
   my $in_str = shift;
   my $year   = shift;
   my $month  = shift;
   my $day    = shift;

   # Strip off any leading zeros so we can use the hashes for validation ...
   $month =~ s/^0+//;
   $day   =~ s/^0+//;

   # Standardize it ... (with digits only!)
   $month = $Months{lcx($month)};
   $day   = $Days{lcx($day)};

   # Helpfull when dealing with foreign languages.
   my $err_msg;
   if ( defined $month && defined $day ) {
      ;      # Good date!
   } elsif ( defined $month ) {
      $err_msg = "Just the day of month is bad.";
   } elsif ( defined $day ) {
      $err_msg = "Just the month is bad.";
   } else {
      $err_msg = "Both the month and day are bad.";
   }

   unless ( $err_msg ) {
      if ( 1 <= $day && $day <= $days_in_months[$month] ) {
         ;  # It's a good date ...
      } elsif ( $month == 2 && $day == 29 ) {
         my $leap = _is_leap_year ($year);
         $year = undef  unless ( $leap );
      } else {
         $year = undef;
      }
      unless ( defined $year ) {
         $err_msg = "The day of month is out of range.";
      }
   }

   if ( $err_msg ) {
      DBUG_PRINT ("ERROR", "'%s' was an invalid date!\n%s", $in_str, $err_msg);
      DBUG_PRINT ("BAD", "%s-%s-%s", $year, $month, $day);
      return ( DBUG_RETURN (undef) );
   }

   DBUG_RETURN ( sprintf ("%04d-%02d-%02d", $year, $month, $day) );
}

# --------------------------------------------------------------
sub _find_month_in_string
{
   DBUG_ENTER_FUNC (@_);
   my $date_str = shift;

   my $month;
   my $digits = 0;

   my @lst = sort { length($b) <=> length($a) || $a cmp $b } keys %Months;

   foreach my $m ( @lst ) {
      # Ignore numeric keys, can't get the correct one from string ...
      next  if ( $m =~ m/^\d+$/ );

      my $flag1 = ( $last_language_edit_flags{month_period} &&
                    $m =~ s/[.]/\\./g );

      if ( $date_str =~ m/(${m})/ ) {
         $month = $1;
         $month =~ s/[.]/\\./g  if ( $flag1 );
         last;
      }
   }

   # Allow any number between 1 and 12 ...
   unless ( $month ) {
      $month = "[1-9]|0[1-9]|1[0-2]";
      $digits = 1;
   }

   DBUG_RETURN ( $month, $digits );   # Suitable for use in a RegExpr.
}

# --------------------------------------------------------------
sub _find_day_of_month_in_string
{
   DBUG_ENTER_FUNC (@_);
   my $date_str    = shift;
   my $skip_period = shift;        # Skip entries ending in '.' like 17.!
   my $month_str   = shift;        # Will be undef if skip_period is true!

   my $day;
   my $digits = 0;

   my @lst = sort { length($b) <=> length($a) || $a cmp $b } keys %Days;

   my $all_digits = $skip_period ? "^\\d+[.]?\$" : "^\\d+\$";

   foreach my $dom ( @lst ) {
      # Ignore numeric keys, can't get the correct one from string ...
      next  if ( $dom =~ m/${all_digits}/ );

      my $flag1 = ( $last_language_edit_flags{dsuf_period} &&
                    $dom =~ s/[.]/\\./g );

      if ( $month_str ) {
         # Makes sure dom doesn't match month name ...
         $month_str =~ s/[.]/\\./g;
         if ( $date_str =~ m/${month_str}.*(${dom})/ ||
              $date_str =~ m/(${dom}).*${month_str}/ ) {
            $day = $1;
            $day =~ s/[.]/\\./g  if ( $flag1 );
            last;
         }

      # There is no month name to worry about ...
      } elsif ( $date_str =~ m/(${dom})/ ) {
         $day = $1;
         $day =~ s/[.]/\\./g  if ( $flag1 );
         last;
      }
   }

   # Allow any number between 1 and 31 ...
   unless ( $day ) {
      $day = "[1-9]|0[1-9]|[12][0-9]|3[01]";
      $digits = 1;
   }

   DBUG_RETURN ( $day, $digits );   # Suitable for use in a RegExpr.
}

# ==============================================================

=item adjust_future_cutoff ( $num_years );

Changes the cutoff future date from B<30> years to I<$num_years>.

Set to B<0> to disable years in the future!

This affects all L<Advanced::Config> objects, not just the current one.

=cut

sub adjust_future_cutoff
{
   DBUG_ENTER_FUNC ( @_ );
   my $years = shift;

   if ( defined $years && $years =~ m/^\d+$/ ) {
      $global_cutoff_date = shift;
   }

   DBUG_VOID_RETURN ();
}