view release on metacpan or  search on metacpan

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

=cut

# ==============================================================
sub get_get_opts
{
   DBUG_ENTER_FUNC ( @_ );
   my $user_opts = shift;
   my $current   = shift;

   # Get the default values ...
   my %def = %default_get_opts;
   my $ref = \%def;

   $ref = _get_opt_base ( $current, $ref )    if ( defined $current );
   $ref = _get_opt_base ( $user_opts, $ref )  if ( defined $user_opts );

   # Some additional validation ...
   unless ( 0 <= $ref->{date_format} && $ref->{date_format} <= 8 ) {
      my $val = $ref->{date_format};
      $ref->{date_format} = $default_read_opts{date_format};
      warn ("Option 'date_format' is invalid ($val).  Resetting to it's default!\n");
   }

   DBUG_RETURN ( $ref );
}

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

=item $dopts = get_date_opts ( [\%user_opts[, \%current_opts]] )

This method takes the I<user's> options that override the behavior of I<date>
formatting for this module and merges it into the I<current> options.  If no
I<current> options hash reference is given, it will use the module's defaults
instead.

It returns a hash reference of all applicable "Date" formatting options.

=cut

# ==============================================================
sub get_date_opts
{
   DBUG_ENTER_FUNC ( @_ );
   my $user_opts = shift;
   my $current   = shift;

   # Get the default values ...
   my %def = %default_date_opts;
   my $ref = \%def;

   $ref = _get_opt_base ( $current, $ref )    if ( defined $current );
   $ref = _get_opt_base ( $user_opts, $ref )  if ( defined $user_opts );

   DBUG_RETURN ( $ref );
}

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

=item $ref = apply_get_rules ( $tag, $section, $val1, $val2, $wide, $getOpts )

Returns an updated hash reference containing the requested data value after all
the I<$getOpts> rules have been applied.  If the I<$tag> doesn't exist then it
will return B<undef> instead or B<die> if it's I<required>.

I<$val1> is the DATA hash value from the specified section.

I<$val2> is the DATA hash value from the parent section.  This value is ignored
unless the I<inherit> option was specified via I<$getOpts>.

I<$wide> tells if UTF-8 dates are allowed.

=cut

# ==============================================================
sub apply_get_rules
{
   DBUG_ENTER_FUNC (@_);
   my $tag      = shift;     # The tag we are processing ...
   my $section  = shift;     # The name of the current section ...
   my $value1   = shift;     # The value hash from the current section ...
   my $value2   = shift;     # The value hash from the "main" section ...
   my $wide_flg = shift;     # Tells if langages like Greek are allowed ...
   my $get_opts = shift;     # The current "Get" options hash ...

   # Did we find a value to process?
   my $data = $value1;
   if ( $get_opts->{inherit} && (! defined $data) ) {
      $data = $value2;
   }
   unless ( defined $data ) {
      return DBUG_RETURN ( croak_helper ( $get_opts,
                                  "No such tag ($tag) in section ($section).",
                                  undef ) );
   }

   # Make a local copy to work with, we don't want to modify the source.
   # We're only interested in two entries from the hash:  VALUE & MASK_IN_FISH.
   # All others are ignored by this method.
   my %result = %{$data};

   # Do we split up the value?    ( Took 2 options to implement the split. )
   my @vals;
   unless ( $get_opts->{split} ) {
      push (@vals, $result{VALUE});    # Nope!

   } else {
      @vals = split ( $get_opts->{split_pattern}, $result{VALUE} );
      $result{VALUE} = \@vals;
   }

   # Only if sorting, assume everything in the list is numeric ...
   my $is_all_numbers = $get_opts->{sort} ? 1 : 0;

   # Do any validation that needs to be done against the individual parts ...
   foreach my $v ( @vals ) {
      my $old = $v;   # Save in case someone modifies $v!

      # -------------------------------------------------------------------
      # Do we need to convert to upper or lower case?
      if ( $get_opts->{vcase} > 0 ) {
         $v = uc ( $v );