view release on metacpan or  search on metacpan

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

   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 );
      } elsif ( $get_opts->{vcase} < 0 ) {
         $v = lc ( $v );
      }

      # -------------------------------------------------------------------
      # Convert into a boolean value ??? (you never see the original value)
      if ( $get_opts->{auto_true} ) {
         $result{MASK_IN_FISH} = 0;    # Boolean values are never sensitive!

         my $numeric = 0;
         if ( $old =~ m/^[-+]?\d+([.]\d*)?$/ ||
              $old =~ m/^[-+]?[.]\d+$/ ) {
            $numeric = 1;
            $old += 0;       # Convert string to a number ...
         }

         $v = 0;           # Assume FALSE ...
         unless ( $old ) {
            ;
         } elsif ( $numeric ) {
            $v = 1;        # It's TRUE for a non-zero numeric value ...
         } elsif ( $old =~ m/(^true[.!;]?$)|(^yes[.!;]?$)|(^good[.!;]?$)|(^[TYG]$)|(^on[.!;]?$)/i ) {
            $v = 1;        # It's TRUE for certain text strings ...
         }

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

{
   DBUG_ENTER_FUNC ( @_ );
   my $ropts = shift;

   my $def = 0;     # Assume not using the default quotes ...

   unless ( $ropts->{disable_quotes} ) {
      if ( $ropts->{quote_left} eq $ropts->{quote_right} ) {
         if ( $ropts->{quote_left} eq  "['\"]"  ||
              $ropts->{quote_left} eq  "[\"']" ) {
            $def = 1;
         }
      }
   }

   DBUG_RETURN ( $def );
}


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

=item $str = convert_to_regexp_string ( $string[, $no_logs] )

Converts the passed string that may contain special chars for a Perl RegExp
into something that is a literal constant value to Perl's RegExp engine by
turning these problem chars into escape sequences.

It then returns the new string.

If I<$no_logs> is set to a non-zero value, it won't write anything to the logs.

=cut

sub convert_to_regexp_string
{
   my $no_fish = $_[1];
   DBUG_ENTER_FUNC ( @_ )  unless ( $no_fish );;
   my $str     = shift;

   # The 8 problem chars with special meaning in a RegExp ...
   # Chars:  . + ^ | $ \ * ?
   $str =~ s/([.+^|\$\\*?])/\\$1/g;  

   # As do these 3 types of brackets: (), {}, []
   $str =~ s/([(){}[\]])/\\$1/g;

   return DBUG_RETURN ( $str )  unless ( $no_fish );
   return ( $str );
}

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

=item $str = convert_to_regexp_modifier ( $string )

Similar to C<convert_to_regexp_string> except that it doesn't convert
all the wild card chars.

Leaves the following RegExp wild card's unescaped!
S<(B<*>, B<?>, B<[>, and B<]>)>

Used when processing variable modifier rules.

=cut

sub convert_to_regexp_modifier
{
   DBUG_ENTER_FUNC ( @_ );
   my $str     = shift;

   # The 6 problem chars with special meaning in a RegExp ...
   # Chars:  . + ^ | $ \    (Skips * ?)
   $str =~ s/([.+^|\$\\])/\\$1/g;  

   # As do these 2 of 3 types of brackets: () & {}, not []
   $str =~ s/([(){}])/\\$1/g;

   DBUG_RETURN ( $str );
}

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

=item $sensitive = should_we_hide_sensitive_data ( $tag )

Checks the tag against an internal list of patterns to see if there is a match.
This check is done in a case insensitive way.

If there is a match it will return true and the caller should take care about
writing anything about this tag to any log files.

If there is no match it will return false, and you can write what you please to
your logs.

See I<make_it_sensitive> to add additional patterns to the list.

=cut

sub should_we_hide_sensitive_data
{
   my $tag       = shift;
   my $skip_fish = shift;     # Undocumented ...

   my $sensitive = 0;    # Assume it's not to be hidden!

   foreach my $hide ( @hide_from_fish ) {
      if ( $tag =~ m/${hide}/i ) {
         $sensitive = 1;   # We found a match!  It's sensitive!
      }
   }

   unless ( $skip_fish ) {
      DBUG_ENTER_FUNC ( $tag, $skip_fish, @_ );
      return DBUG_RETURN ( $sensitive );
   }

   return ( $sensitive );
}

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

=item make_it_sensitive ( @patterns )