view release on metacpan or  search on metacpan

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

   $default_read_opts{tag_case}   = 0;         # Case sensitive tags.

   # The generic options ...
   my %src_empty;
   $default_read_opts{croak}      = 0;         # Don't croak by default.
   $default_read_opts{export}     = 0;         # Don't export any tag/val pairs.
   $default_read_opts{use_utf8}   = 0;         # Doesn't support utf8/Unicode/Wide Chars.
   $default_read_opts{disable_quotes}     = 0; # Don't disable balanced quotes.
   $default_read_opts{disable_variables}  = 0; # Don't disable variables!
   $default_read_opts{disable_variable_modifiers} = 0; # Don't disable variable modifiers!
   $default_read_opts{disable_decryption} = 0; # Don't disable decryption!
 # $default_read_opts{enable_backquotes}  = 0; # Don't allow random command execution.
   $default_read_opts{trap_recursion}     = 0; # Recursion is ignored, not fatal
   $default_read_opts{source_cb}  = __PACKAGE__->can ("_source_callback_stub");
   $default_read_opts{source_cb_opts} = \%src_empty;

   # The file parsing options ...
   $default_read_opts{assign}          = '=';   # The assignment operator
   $default_read_opts{comment}         = '#';   # The comment symbol
   $default_read_opts{source}          = '.';   # The file source symbol
   $default_read_opts{section_left}    = '[';   # The start section string
   $default_read_opts{section_right}   = ']';   # The end section string
   $default_read_opts{variable_left}   = '${';  # The start variable string
   $default_read_opts{variable_right}  = '}';   # The end variable string

   # Unlikely default values due to security concerns.
   # $default_read_opts{backquote_left}  = '`'x101;  # The start backquote string
   # $default_read_opts{backquote_right} = '`'x102;  # The end backquote string

   # The quote chars ... (Special case doesn't work for anything else.)
   # See  using_default_quotes()  if this changes ...
   $default_read_opts{quote_left} = $default_read_opts{quote_right} = "['\"]";

   # The tag/value modifiers.  These labels are found inside the comments!
   $default_read_opts{export_lbl}  = "EXPORT";    # Label for a single %ENV.
   $default_read_opts{hide_lbl}    = "HIDE";      # Mark as sensitive.
   $default_read_opts{encrypt_lbl} = "ENCRYPT";   # Pending encryption.
   $default_read_opts{decrypt_lbl} = "DECRYPT";   # Already encrypted.
   $default_read_opts{source_file_section_lbl} = "DEFAULT";  # Override default.

   # The Encrypt/Decrypt options ... (Encode/Decode)
   my %empty_encrypt;
   $default_read_opts{alias}               = "";
   $default_read_opts{pass_phrase}         = "";
   $default_read_opts{inherit_pass_phrase} = 0;
   $default_read_opts{encrypt_by_user}     = 0;
   $default_read_opts{encrypt_cb}      = __PACKAGE__->can ("_encryption_callback_stub");
   $default_read_opts{encrypt_cb_opts} = \%empty_encrypt;

   # Special undocumented test prog option for overriding fish in parse_line().
   $default_read_opts{dbug_test_use_case_parse_override} = 0;  # Always off.

   # Special undocumented test prog option for overriding fish in read_config().
   $default_read_opts{dbug_test_use_case_hide_override} = 0;   # Always off.


   # ---------------------------------------------------------------------

   DBUG_PRINT ("INFO", "Initializing the GET options global hash ...");
   # Should always be set in the constructor ...
   $default_get_opts{inherit} = 0;        # Can inherit from the parent section.

   # The generic options ... Who cares where set!
   $default_get_opts{required}  = 0;         # Return undef by default.
   $default_get_opts{vcase}     = 0;         # Case of the value. (0 = as is)
   $default_get_opts{split_pattern} = qr /\s+/;  # Space separated lists.

   # Used in parsing dates for get_date() ...
   $default_get_opts{date_language}      = "English"; # The language to use in parsing dates.
   $default_get_opts{date_language_warn} = 0;         # Disable warnings in Date.pm.
   $default_get_opts{date_dl_conversion} = 0;         # 1-Enable 0-Disable using Date::Language for parsing.
   $default_get_opts{date_enable_yy}     = 0;         # 1-Enable 0-Disable using 2 digit years in a date!
   $default_get_opts{date_format}        = 3;         # Hints are 0 to 8.

   # These special case options not to show up in the POD ...
   # All associated with special "get_*()" functions that will auto set if needed.
   $default_get_opts{numeric}     = 0;       # 0-no, 1-integer (truncate), 2-integer (round), 3-real.
   $default_get_opts{auto_true}   = 0;       # Don't return as boolean.
   $default_get_opts{filename}    = 0;       # Tag doesn't do a file test.
   $default_get_opts{directory}   = 0;       # Tag doesn't do a directory test.
   $default_get_opts{split}       = 0;       # Don't split the value.
   $default_get_opts{sort}        = 0;       # Don't sort the split value. (1 - sort, -1 - reverse sort)
   $default_get_opts{date_active} = 0;       # 0-No, 1-Yes expecing it to be a date.


   # ---------------------------------------------------------------------

   DBUG_PRINT ("INFO", "Initializing the DATE formatting options global hash ...");
   $default_date_opts{date_order}     = 0;          # 0 - YMD, 1 - MDY, 2 - DMY
   $default_date_opts{date_sep}       = "-";        # Separator to format dates with.
   $default_date_opts{month_type}     = 0;          # 0 - numeric, 1 - abbreviate, 2 - full.
   $default_date_opts{month_language} = "English";  # See Date::Language.
   $default_date_opts{use_gmt}        = 0;          # 0 - localtime, 1 - gmtime.
   # $default_date_opts{timestamp}    = ?;          # Special case can't set directly.

   # ---------------------------------------------------------------------


   DBUG_VOID_RETURN ();
}

# ==============================================================
# A private helper method ... (not exported)
sub _get_opt_base
{
   DBUG_ENTER_FUNC ( @_ );
   my $user_opts = shift;
   my $defaults  = shift;    # Which default hash to validate against ...

   # Make own copy of the defaults hash ...
   my %result = %{$defaults};

   # Must warn about invalid key values ...
   foreach ( sort keys %{$user_opts} ) {
      my $k = lc ($_);
      my $val = $user_opts->{$_};

      unless ( exists $defaults->{$k} ) {
         warn "Unknown option '$k'.  Option ignored.\n";
         next;
      }

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

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

      # -------------------------------------------------------------------
      # Convert into a boolean value ??? (you never see the original value)