view release on metacpan or  search on metacpan

lib/Data/Checker.pm  view on Meta::CPAN

      my $caller = ( caller() )[0];

      TRY:
      foreach my $name ("${type}",
                        "${type}::check",
                        "${caller}::${type}",
                        "${caller}::${type}::check",
                        "Data::Checker::${type}",
                        "Data::Checker::${type}::check",
                       ) {

         # Ignore the case where $name does not have '::' because that means
         # we called it with the name of a function in the CALLER namespace
         # (so it'll get handled by one of the "${caller}::" cases, or $type
         # is a sub-namespace of Data::Checker.

         next  if ($name !~ /^(.*)::(.+)$/);
         my($mod) = ($1);
         $mod = "main"  if (! defined $mod);

         # Try loading the module (but not main:: or CALLER::

         if ($mod ne 'main'  &&
             $mod ne $caller  &&
             ! is_loaded($mod)) {
            next TRY  if (! eval "require $mod");
         }

         # Look for the function

         no strict 'refs';
         if (defined &{$name}) {
            $func = \&{$name};
            last TRY;
         }
      }

      die "ERROR: no valid check function passed to Data::Checker::check\n"
        if (! defined $func);
   }

   # Call parallel or serial check

   if ($$self{'parallel'} != 1) {
      return $self->_check_parallel(\%data,$wantlist,$func,$opts);
   } else {
      return $self->_check_serial(\%data,$wantlist,$func,$opts);
   }
}

sub _check_parallel {
   my($self,$data,$wantlist,$func,$opts) = @_;
   my(%pass,%fail,%info,%warn);
   my @ele      = keys %$data;
   my $max_proc = ($$self{'parallel'} > 1 ? $$self{'parallel'} : @ele);

   my $manager = Parallel::ForkManager->new($max_proc);
   $manager->run_on_finish
     (
      sub {
         my($pid,$exit_code,$id,$signal,$core_dump,$funcdata) = @_;
         my($ele,$err,$warn,$info) = @$funcdata;

         if (defined($err)  &&  @$err) {
            $fail{$ele} = $err;
         } else {
            $pass{$ele} = $$data{$ele};
         }

         if (defined($warn)  &&  @$warn) {
            $warn{$ele} = $warn;
         }
         if (defined($info)  &&  @$info) {
            $info{$ele} = $info;
         }
      });

   ELE:
   foreach my $ele (sort keys %$data) {
      $manager->start and next;

      my($element,$err,$warn,$info) = &$func($self,$ele,$$data{$ele},$opts);

      $manager->finish(0,[$element,$err,$warn,$info]);
   }

   $manager->wait_all_children();

   if ($wantlist) {
      my @pass = sort keys %pass;
      return (\@pass,\%fail,\%warn,\%info);
   } else {
      return (\%pass,\%fail,\%warn,\%info);
   }
}

sub _check_serial {
   my($self,$data,$wantlist,$func,$opts) = @_;
   my(%pass,%fail,%info,%warn);

   ELE:
   foreach my $ele (sort keys %{ $data }) {
      my($element,$err,$warn,$info) = &$func($self,$ele,$$data{$ele},$opts);

      if (defined($err)  &&  @$err) {
         $fail{$ele} = $err;
      } else {
         $pass{$ele} = $$data{$ele};
      }

      if (defined($warn)  &&  @$warn) {
         $warn{$ele} = $warn;
      }
      if (defined($info)  &&  @$info) {
         $info{$ele} = $info;
      }
   }

   if ($wantlist) {
      my @pass = sort keys %pass;
      return (\@pass,\%fail,\%warn,\%info);
   } else {