view release on metacpan or  search on metacpan

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

   } elsif ( ! $rOpts->{disable_quotes} ) {
      ($lq, $rq) = (  $rOpts->{quote_left}, $rOpts->{quote_right} );
   }

   return ( $lq, $rq );
}


# ==============================================================
# USAGE:  $val = _encrypt ($value, $pass_code, $tag, $alias, $usr_flg)
#
# Both encrypts & decrypts the value ...

sub _encrypt
{
  DBUG_MASK_NEXT_FUNC_CALL (0, 1); # Masks ${val} & ${pass} ...
  DBUG_ENTER_FUNC ( @_ );
  my $val     = shift;             # Sensitive ... if not already encrypted.
  my $pass    = shift;             # Very, very sensitive ... always clear text.
  my $tag     = shift;
  my $alias   = shift;
  my $usr_flg = shift;             # 0 - no, 1 - yes
  DBUG_MASK (0);

  # Verify lengths are different to prevent repeatable patterns.
  if ( length ( $tag ) == length ( $alias ) ) {
     $tag .= "|";      # Make different lengths
  }

  my $len = length ( $val );

  my $key1 = _make_key ( $tag, $len );
  my $key2 = _make_key ( $alias, $len );
  my $res = $key1 ^ $key2;

  if ( $pass ) {
     my $key3 = _make_key ( $pass, $len );
     $res = $res ^ $key3;
  }

  if ( $usr_flg ) {
     my $key4 = _make_key ( $gUserName, $len );
     $res = $res ^ $key4;
  }

  unless ( $val =~ m/[^\x00-\xff]/ ) {
     $res = $res ^ $val;   # ascii ...
  } else {
     # Unicode version of ($res ^ $val) ...
     $res = _bitwise_exclusive_or ( $res, $val );
  }

  DBUG_RETURN ( $res );    # Sometimes encrypted and other times not!
}

# ==============================================================
sub _bitwise_exclusive_or
{
   DBUG_ENTER_FUNC ();   # Dropped @_ on purpose, always sensitive
   my $mask    = shift;
   my $unicode = shift;
   DBUG_MASK (0);

   my @m = unpack ("C*", $mask);
   my @u = unpack ("U*", $unicode);

   my @ans;
   foreach ( 0..$#u ) {
      $ans[$_] = $m[$_] ^ $u[$_];   # Exclusive or of 2 integers still supported.
   }

   DBUG_RETURN ( pack ("U*", @ans) );
}

# ==============================================================
# USAGE: $key = _make_key ($target, $len);

sub _make_key
{
   DBUG_MASK_NEXT_FUNC_CALL (0);    # Masks ${target} ...
   DBUG_ENTER_FUNC ( @_ );
   my $target = shift;     # May be ascii or unicode ...
   my $len    = shift;
   DBUG_MASK (0);

   my $phrase;
   unless ( $target =~ m/[^\x00-\xff]/ ) {
      # Normal text ... (ascii)
      $phrase = $target . pack ("C*", reverse (unpack ("C*", $target)));

   } else {
      # Unicode strings (utf8 / Wide Chars)
      # Strip off the upper byte from each unicode char ...
      my @ans = map { $_ % 0x100 } unpack ("U*", $target);
      $phrase = pack ("C*", @ans) . pack ("C*", reverse (@ans));
   }

   my $key = $phrase;
   while ( length ( $key ) < $len ) {
      $key .= $phrase;
   }

   $key = substr ( $key, 0, $len );     # Truncate it to fit ...

   DBUG_RETURN ( $key );    # Always an ascii string ...
}

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

=back

=head1 COPYRIGHT

Copyright (c) 2007 - 2026 Curtis Leach.  All rights reserved.

This program is free software.  You can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 SEE ALSO

L<Advanced::Config> - The main user of this module.  It defines the Config object.

L<Advanced::Config::Options> - Handles the configuration of the Config module.

L<Advanced::Config::Date> - Handles date parsing for get_date().

L<Advanced::Config::Examples> - Provides some sample config files and commentary.

=cut

# ==============================================================
#required if module is included w/ require command;
1;