view release on metacpan or  search on metacpan

lib/Pod/Inherit.pm  view on Meta::CPAN

    $classname = $tt_stash->{classname} = $self->_pure_filename_to_classname( $root_dir ? $src->relative($root_dir) : $src );
    $self->_check_pod_sections($src, $classname);
  }

  # Check for force inherits to add
  my $force_inherits = (first { $self->_match_filename_to_type_array($classname, $src, [$fit->{$_}, $_]); } keys %$fi) || '';
  $force_inherits = $fi->{$force_inherits};
  if ($force_inherits) {
    # Forced inherits still need to be loaded manually
    foreach my $class (@$force_inherits) {
      print "  Found force inherit: $class\n" if ($DEBUG);
      $self->_require_class(undef, $class) || return;
      push @isa_flattened, @{mro::get_linear_isa($class)};
    }
  }

  # Now for ones to skip (including its own class)
  foreach my $s ( @{ $self->{skip_inherits} }, $classname ) {
    for (my $i = 0; $i < @isa_flattened; $i++) {
      if ($s eq $isa_flattened[$i]) {
        print "  Skipped per skip_inherits: $s\n" if ($DEBUG);
        splice(@isa_flattened, $i--, 1);
      }
    }
  }

  # We can't possibly find anything.  Just short-circuit and save ourselves a lot of trouble.
  if (!@isa_flattened) {
    print "  No parent classes\n" if ($DEBUG);
    return;
  }
  $tt_stash->{isa_flattened} = \@isa_flattened;

  # Read POD sections for new classes
  if (exists $self->{dead_links}) {
    foreach my $class (@isa_flattened) {
      $self->_check_pod_sections(undef, $class);
    }
  }

  my %seen;
  for my $parent_class (@isa_flattened) {
    print "  Parent class: $parent_class\n" if ($DEBUG);
    my $stash;
    {
      no strict 'refs';
      $stash = \%{"$parent_class\::"};
    }
    # There's something subtle and brain-melting going on here, but I think it works.
    my $local_config = $stash->{_pod_inherit_config};
    if (not exists $local_config->{skip_underscored}) {
      $local_config->{skip_underscored} = $self->{skip_underscored};
    }
    $local_config->{class_map}  ||= $class_map;

    for my $globname (sort keys %$stash) {
      next if ($local_config->{skip_underscored} and $globname =~ m/^_/);
      next if $seen{$globname};

      # Skip the typical UPPERCASE sub blocks that aren't really user-friendly methods
      next if ($globname =~ m/^(?:AUTOLOAD|CLONE|DESTROY|BEGIN|UNITCHECK|CHECK|INIT|END)$/);

      my $glob = $stash->{$globname};
      # Skip over things that aren't *code* globs, and cache entries.
      # (You might think that ->can will return false for non-code globs.  You'd be right.  It'll return true
      # for cache globs, and we want to skip those, so that we'll get them later.)
      my $exists;
      eval {
        # Don't next here directly, it'll cause a warning.
        $exists = exists &$glob;
      };
      if ($@) {
        # This specific error happens in DBIx::Class::Storage O_LARGEFILE, which is exported from IO::File
        # (I loose track of exactly how...)
        # Strange, considering O_LARGEFILE clearly *is* a subroutine...
        if ($@ =~ /Not a subroutine reference/) {
          print "  Got not a subref for $globname in $parent_class; it is probably imported accidentally.\n" if ($DEBUG);
          $exists=0;
        } else {
          die "While checking if $parent_class $globname is a sub: $@";
        }
      }
      next unless ($exists);

      # This should probably be in the template.
      my $nice_name;
      if ($globname eq '()') {
        $nice_name = 'I<overload table>';
      } elsif ($globname =~ m/^\((.*)/) {
        my $sort = $1;
        $sort =~ s/(.)/sprintf "E<%d>", ord $1/ge;
        $nice_name = "I<$sort overloading>";
      } else {
        $nice_name = $globname;
      }

      my $subref = $classname->can($globname);
      if ($force_inherits && !$subref) {  # forced inherits may be the ones with the methods...
        foreach my $class (@$force_inherits) {
          $subref = $class->can($globname)
            unless defined $subref;
        }
      }
      # Must not be a method, but some other strange beastie.
      next if !$subref;

      my $identify_name = Sub::Identify::stash_name($subref);
      # No reason to list it, really.  Then again, no reason not to,
      # really...  Yes there is.  It's just noise for anybody who actually knows perl.
      next if $identify_name eq 'UNIVERSAL';

      if ($identify_name ne $parent_class) {
        # warn "Probable unexpected import of $nice_name from $identify_name into $parent_class"
        #   if $] >= 5.010;
        next;
      }
      # Note that this needs to happen *after* we determine if it's a cache entry, so that we *will* get them later.
      $seen{$globname} = $parent_class;
#      push @derived, { $parent_class => $nice_name };

      my $doc_parent_class = $local_config->{class_map}->{$parent_class} || $parent_class;