view release on metacpan or  search on metacpan

t/55-validate-strings.t  view on Meta::CPAN

   # It's a fatal error if any tag in the "bad" array doesn't exist!
   foreach ( @{$bad} ) {
      my $s = $src->get_value ($_);
      my $d = $dst->get_value ($_);
      if ( $s eq $d ) {
         $ok = 0;
         dbug_ok (0, "Tags $_ match when they shouldn't!  (${s})");
      }
   }

   DBUG_RETURN ( $ok );
}

# ====================================================================
# Tests the results.
# Only prints out failures when testing the contents.
# There are just too many tests otherwise to debug things!
# ====================================================================
sub test_results
{
   DBUG_ENTER_FUNC ( @_ );
   my $cfg = shift;
   my $mis = shift;   # The list of tags not in the string config.

   my @lst1 = sort keys %Config;
   my @lst2 = sort $cfg->find_tags ();

   my $cnt1 = @lst1;
   my $cnt2 = @lst2;

   # Convert the "string" config file into a hash to simplify testing ...
   my %val2;
   foreach ( @lst2 ) {
      my $val = $cfg->get_value ( $_ );
      $val2{$_} = $val;
   }

   # Now add in the missing entries ... (no overrides)
   foreach ( sort keys %{$mis} ) {
      next  if ( exists $val2{$_} );
      $val2{$_} = $mis->{$_};
      ++$cnt2;
   }

   dbug_is ($cnt1, $cnt2, "The object has the correct number of tags in it!  ($cnt1 vs $cnt2)");

   # Checks to see if there were any tags in the string that wasn't in %Config.
   foreach ( @lst2 ) {
      unless ( exists $Config{$_} ) {
         dbug_ok (0, "Found tag $_ in the %Config hash!");
      }
   }

   # Only prints out errors.  Otherwise over 1,000 tests printed out.
   foreach ( @lst1 ) {
      unless ( exists $val2{$_} ) {
         dbug_ok ( 0, "Tag $_ exists in the string config file!");
         next;
      }

      # Some Config values are undefined ...
      unless ( defined $Config{$_} ) {
         if ( $val2{$_} ne "undef" ) {
            dbug_ok ( 0, "Tag $_ is set to 'undef'.  ($val2{$_})");
         }
         next;
      }

      if ( $Config{$_} ne $val2{$_} ) {
         dbug_ok ( 0, "Tag $_ is set to the proper value ($Config{$_} vs $val2{$_})" );
         next;
      }
   }

   DBUG_VOID_RETURN ();
}

# ====================================================================
# Determines which keys in the %Config hash are not in the string!
sub find_missing_entries
{
   DBUG_ENTER_FUNC ( @_ );

   # Get a complete list of what's in the Config string returned.
   my $str = config_sh ();
   my @lst = split ("\n", $str);

   # Build a hash out of the string ... (tag='value')
   my %found;
   foreach (@lst) {
      my ($tag, $value) = split ("=", $_, 2);
      $value = $1  if ( $value =~ m/^'(.*)'$/ );
      $found{$tag} = $value;   # Without quotes!
   }

   # Now determine which are missing from the string ...
   my $cnt = 0;
   my %missing;
   foreach ( sort keys %Config ) {
      next  if ( exists $found{$_} );
      $missing{$_} = (defined $Config{$_}) ? $Config{$_} : "undef"; 
      DBUG_PRINT ("MISSING", "Found missing tag: %s\n<%s>", $_, $missing{$_});
      ++$cnt;
   }

   dbug_ok ( 1, "There were $cnt missing entries in the Config String.");

   DBUG_RETURN ( \%missing );
}

# ====================================================================
sub init_config
{
   DBUG_ENTER_FUNC ( @_ );
   my $in_string = shift || config_sh ();
   my $alias     = shift;
   my $extra     = shift;

   my $cfg;
   my ( %rOpts, %gOpts, %dOpts );

   $rOpts{Croak} = 1;      # Call die on error.
   $gOpts{Required} = 1;   # Call die if the tag doesn't exist.

   # Did we ask to change some defauls?
   if ( $extra ) {
      $rOpts{Comment} = "//";
      $rOpts{Assign} = ":=:";

      # Commented out on purpose ...
      # $rOpts{encrypt_lbl} = "Some Comments ...";
   }

   # Did we override the read options to use with the string?
   my %oOpts;
   $oOpts{alias} = $alias   if ( $alias );

   eval {
      $cfg = Advanced::Config->new (undef, \%rOpts, \%gOpts, \%dOpts);
      dbug_isa_ok ($cfg, 'Advanced::Config');
      my $ldr = $cfg->load_string ( $in_string, \%oOpts );
      dbug_ok (defined $ldr, "Advanced::Config contents have been loaded into memory!");
   };
   if ( $@ ) {
      unless (defined $cfg) {
         dbug_isa_ok ($cfg, 'Advanced::Config');
      }
      dbug_ok (0, "Advanced::Config contents have been loaded into memory!");
      DBUG_LEAVE (3);
   }

   # So can tell when the config files were loaded in fish ...
   DBUG_PRINT ("====", "%s", "-"x50);

   DBUG_RETURN ( $cfg );
}