view release on metacpan or  search on metacpan

Config.pm  view on Meta::CPAN

   my $disable_req = shift;

   # Get the main/parent section to work against!
   my $pcfg = $self->{PARENT} || $self;

   # Determine what the "get" options must be ...
   my $get_opts = $pcfg->{CONTROL}->{get_opts};
   $get_opts = get_get_opts ( $opts, $get_opts )  if ( $opts );

   # Check if a case insensitive lookup was requested ...
   my $t = ( $pcfg->{CONTROL}->{read_opts}->{tag_case} && $tag ) ? lc ($tag) : $tag;

   # Check if we're overriding the required flag ...
   my $req = $get_opts->{required};
   local $get_opts->{required} = $disable_req ? 0 : $req;

   # Returns a hash reference to a local copy of the tag's data ... (or undef)
   # Handles the inherit option if used.
   my $data_ref =apply_get_rules ( $tag, $self->{SECTION_NAME},
                              $self->{DATA}->{$t}, $pcfg->{DATA}->{$t},
                              $pcfg->{CONTROL}->{ALLOW_UTF8},
                              $get_opts );

   return ( wantarray ? ($data_ref, $req) : $data_ref );
}


# Private method ...
# Gets the requested tag value from the current section.
# Returns: All 5 of the hash members individually ... + required flag setting.
sub _base_get2
{
   my $self = shift;
   my $tag  = shift;
   my $opts = shift;

   my ($data, $req) = $self->_base_get ( $tag, $opts, 0 );

   if ( defined $data ) {
      return ( $data->{VALUE}, $data->{MASK_IN_FISH}, $data->{FILE}, $data->{ENCRYPTED}, $data->{VARIABLE}, $req );
   } else {
      return ( undef, 0, "", 0, 0, $req );    # No such tag ...
   }
}


# Private method ...
# Gets the requested tag date value from the current section.
# or treat the tag name as the date if the tag doesn't exist!
# Returns: All 5 of the hash members individually ... + required flag setting.
sub _base_get3_date_str
{
   my $self        = shift;
   my $tag         = shift;
   my $opts        = shift;
   my $hyd_flg     = shift;         # Is it OK to return a HYD as HYD?
   my $cvt_hyd_flg = shift;         # Is it OK to convert a HYD into a date str?

   if ($hyd_flg && $cvt_hyd_flg) {
      local $opts->{required} = 1;
      croak_helper ($opts, "Programming error!  Can't set both hyd flags to true.", undef);
   }

   my ($data, $req);
   {
      local $opts->{date_active} = 0;
      ($data, $req) = $self->_base_get ( $tag, $opts, 1 );     # Does tag exist?
   }

   # If the tag doesn't exist, use $tag as a date string instead.
   unless ( defined $data ) {
      my $yr = _validate_date_str ($tag);
      if ( defined $yr ) {
          return ( $tag, 0, "", 0, 0, $req );     # We have a valid date string!
      } elsif ( $hyd_flg && $tag =~ m/^[-]?\d+$/ ) {
          return ( $tag, 0, "", 0, 0, $req );     # We have a valid HYD string!
      } elsif ( $cvt_hyd_flg && $tag =~ m/^[-]?\d+$/ ) {
          my $dt = convert_hyd_to_date_str ($tag);
          return ( $dt, 0, "", 0, 0, $req );      # We have a valid date string!
      } else {
          local $opts->{required} = $req;
	  croak_helper ($opts, "No such tag ($tag), nor is it a date string.", undef);
          return ( undef, 0, "", 0, 0, $req );    # No such tag/date ...
      }
   }

   # The tag exists, then it must reference a date!
   local $opts->{date_active} = 1;
   ($data, $req) = $self->_base_get ( $tag, $opts, 0 );

   if ( defined $data ) {
      return ( $data->{VALUE}, $data->{MASK_IN_FISH}, $data->{FILE}, $data->{ENCRYPTED}, $data->{VARIABLE}, $req );
   } else {
      return ( undef, 0, "", 0, 0, $req );    # Not a date ...
   }
}


#######################################

=back

=head2 Accessing the contents of an Advanced::Config object.

These methods allow you to access the data loaded into this object.

They all look in the current section for the B<tag> and if the B<tag> couldn't
be found in this section and the I<inherit> option was also set, it will then
look in the parent/main section for the B<tag>.  But if the I<inherit> option
wasn't set it wouldn't look there.

If the requested B<tag> couldn't be found, they return B<undef>.  But if the
I<required> option was used, it may call B<die> instead!

But normally they just return the requested B<tag>'s value.

They all use F<%override_get_opts>, passed by value or by reference, as an
optional argument that overrides the default options provided in the call
to F<new()>.  The I<inherit> and I<required> options discussed above are two
such options.  In most cases this hash argument isn't needed.  So leave it off
if you are happy with the current defaults!

Config.pm  view on Meta::CPAN

      next  if ( $sensitive && should_we_hide_sensitive_data ( $sect, 1 ) );

      my %section_data;
      my $cfg = $self->get_section ($sect, 1);

      my $cnt = 0;
      foreach my $tag ( $cfg->find_tags (undef, 0) ) {
         my ($val, $hide) = $cfg->_base_get2 ($tag);
         next  if ( $sensitive && $hide );
         $section_data{$tag} = $val;
         ++$cnt;
      }

      # Only add a section that has tags in it!
      $data{$sect} = \%section_data  if ( $cnt );
   }

   DBUG_RETURN ( \%data );
}


#######################################

=back

=head2 Encryption/Decryption of your config files.

The methods here deal with the encryption/decryption of your config file before
you use this module to load it into memory.  They allow you to make the contents
of your config files more secure.

=over

=item $status = $cfg->encrypt_config_file ( [$file[, $encryptFile[, \%rOpts]]] );

This function encrypts all tag values inside the specified config file that are
marked as ready for encryption and generates a new config file with everything
encrypted.  If a tag/value pair isn't marked as ready for encryption it is left
alone.  By default this label is B<ENCRYPT>.

After a tag's value has been encrypted, the label in the comment is updated
from B<ENCRYPT> to B<DECRYPT> in the config file.

If you are adding new B<ENCRYPT> tags to an existing config file that already
has B<DECRYPT> tags in it, you must use the same encryption related options in
I<%rOpts> as the last time.  Otherwise you won't be able to decrypt all
encrypted values.

Finally if you provide argument I<$encryptFile>, it will write the encrypted
file to that new file instead of overwriting the current file.  But if you do
this, you will require the use of the I<alias> option to be able to decrypt
it again using the new name.  This file only gets created if the return status
is B<1>.

If you leave off the I<$file> and I<\%rOpts>, it will instead use the values
inherited from the call to B<new>.

This method ignores any request to source in other config files.  You must
encrypt each file individually.

It is an error if basename(I<$file>) is a symbolic link and you didn't provide
I<$encryptFile>.

Returns:  B<1> if something was encrypted.  B<-1> if nothing was encrypted.
Otherwise B<0> on error.

=cut

sub encrypt_config_file
{
   DBUG_ENTER_FUNC ( @_ );
   my $self    = shift;
   my $file    = shift;
   my $newFile = shift;
   my $rOpts   = shift;

   my $pcfg = $self->{PARENT} || $self;

   my $msg;
   if ( $file ) {
      $file = $self->_fix_path ( $file );
   } elsif ( $pcfg->{CONTROL}->{filename} ) {
      $file = $pcfg->{CONTROL}->{filename};
   } else {
      $msg = "You must provide a file name to encrypt!";
   }

   unless ( $msg || -f $file ) {
      $msg = "No such file to encrypt or it's unreadable! -- $file";
   }

   if ( -l $file && ! $newFile ) {
      $msg = "You can't encrypt a file via it's symbolic link -- $file";
   }

   my $scratch;
   if ( $newFile ) {
      $scratch = $self->_fix_path ($newFile);
      if ( $scratch eq $file ) {
         $msg = "Args: file & encryptFile must be different!";
      }
   } else {
      $scratch = $file . ".$$.encrypted";
   }

   if ( $rOpts ) {
      $rOpts = get_read_opts ($rOpts, $pcfg->{CONTROL}->{read_opts});
   } else {
      $rOpts = $pcfg->{CONTROL}->{read_opts};
   }

   if ( $msg ) {
      return DBUG_RETURN ( croak_helper ( $rOpts, $msg, 0 ) );
   }

   my $status = encrypt_config_file_details ($file, $scratch, $rOpts);

   # Some type of error ... or nothing was encrypted ...
   if ( $status == 0 || $status == -1 ) {
      unlink ( $scratch );

   # Replacing the original file ...
   } elsif ( ! $newFile ) {
      unlink ( $file );
      move ( $scratch, $file );
   }

   DBUG_RETURN ( $status );
}


#######################################

=item $status = $cfg->decrypt_config_file ( [$file[, $decryptFile[, \%rOpts]]] );

This function decrypts all tag values inside the specified config file that are
marked as ready for decryption and generates a new config file with everything
decrypted.  If a tag/value pair isn't marked as ready for decryption it is left
alone.  By default this label is B<DECRYPT>.

After a tag's value has been decrypted, the label in the comment is updated
from B<DECRYPT> to B<ENCRYPT> in the config file.

For this to work, the encryption related options in I<\%rOpts> must match what
was used in the call to I<encrypt_config_file> or the decryption will fail.

Finally if you provide argument I<$decryptFile>, it will write the decrypted
file to that new file instead of overwriting the current file.  This file only
gets created if the return status is B<1>.

If you leave off the I<$file> and I<\%rOpts>, it will instead use the values
inherited from the call to B<new>.

This method ignores any request to source in other config files.  You must
decrypt each file individually.

It is an error if basename(I<$file>) is a symbolic link and you didn't provide
I<$decryptFile>.

Returns:  B<1> if something was decrypted.  B<-1> if nothing was decrypted.
Otherwise B<0> on error.

=cut

sub decrypt_config_file
{
   DBUG_ENTER_FUNC ( @_ );
   my $self    = shift;
   my $file    = shift;
   my $newFile = shift;
   my $rOpts   = shift;

   my $pcfg = $self->{PARENT} || $self;

   my $msg;
   if ( $file ) {
      $file = $self->_fix_path ( $file );
   } elsif ( $pcfg->{CONTROL}->{filename} ) {
      $file = $pcfg->{CONTROL}->{filename};
   } else {
      $msg = "You must provide a file name to encrypt!";
   }

   unless ( $msg || -f $file ) {
      $msg = "No such file to decrypt or it's unreadable! -- $file";
   }

   if ( -l $file && ! $newFile ) {
      $msg = "You can't decrypt a file via it's symbolic link -- $file";
   }

   my $scratch;
   if ( $newFile ) {
      $scratch = $self->_fix_path ( $newFile );
      if ( $scratch eq $file ) {
         $msg = "Args: file & decryptFile must be different!";
      }
   } else {
      $scratch = $file . ".$$.decrypted";
   }

   if ( $rOpts ) {
      $rOpts = get_read_opts ($rOpts, $pcfg->{CONTROL}->{read_opts});
   } else {
      $rOpts = $pcfg->{CONTROL}->{read_opts};
   }

   if ( $msg ) {
      return DBUG_RETURN ( croak_helper ( $rOpts, $msg, undef ) );
   }

   my $status = decrypt_config_file_details ($file, $scratch, $rOpts);

   # Some type of error ... or nothing was decrypted ...
   if ( $status == 0 || $status == -1 ) {
      unlink ( $scratch );

   # Replacing the original file ...
   } elsif ( ! $newFile ) {
      unlink ( $file );
      move ( $scratch, $file );
   }

   DBUG_RETURN ( $status );
}


#######################################

=item $out_str = $cfg->encrypt_string ( $string, $alias[, \%rOpts] );

This method takes the passed I<$string> and treats its value as the contents of
a config file, comments and all.  Modifying the I<$string> afterwards will not 
affect things.

Since there is no filename to work with, it requires the I<$alias> to assist
with the encryption.  And since it's required its passed as a separate argument
instead of being buried in the optional I<%rOpts> hash.

It takes the I<$string> and encrypts all tag/value pairs per the rules defined
by C<encrypt_config_file>.  Once the contents of I$<string> has been encrypted,
the encrypted string is returned as I<$out_str>.  It will return B<undef> on
failure.

You can tell if something was encrypted by comparing I<$string> to I<$out_str>.

=cut

sub encrypt_string
{
   DBUG_MASK_NEXT_FUNC_CALL ( 2 );    # mask the alias.
   DBUG_ENTER_FUNC ( @_ );

   my $self      = shift;
   my $string    = shift;    # The string to treat as a config file's contents.
   my $alias     = shift;    # The alias to use during encryption ...
   my $read_opts = $self->_get_opt_args ( @_ );    # The override options ...

   unless ( $string ) {
      my $msg = "You must provide a string to use this method!";
      return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
   }

   unless ( $alias ) {
      my $msg = "You must provide an alias to use this method!";
      return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
   }

   # The filename is a reference to the string passed to this method!
   my $scratch;
   my $src_file = \$string;
   my $dst_file = \$scratch;

   # Put the alias into the read option hash ...