Pod::Inherit - auto-create pod sections listing inherited methods

  use Pod::Inherit;

  my $config = { 
    out_dir => "/usr/src/perl/dbix-class/bast/DBIx-Class/0.08/trunk/doc,
    input_files => ['/usr/src/perl/dbix-class/bast/DBIx-Class/0.08/trunk/lib/'],
    skip_underscored => 1,
    class_map => 
      { 
          "DBIx::Class::Relationship::HasMany" => "DBIx::Class::Relationship", 
          "DBIx::Class::Relationship::HasOne" => "DBIx::Class::Relationship", 
          "DBIx::Class::Relationship::BelongsTo" => "DBIx::Class::Relationship", 
          "DBIx::Class::Relationship::ManyToMany" => "DBIx::Class::Relationship", 
          "DBIx::Class::ResultSourceProxy" => "DBIx::Class::ResultSource",
          "DBIx::Class::ResultSourceProxy::Table" => "DBIx::Class::ResultSource",
      }
   };

  my $pi = Pod::Inherit->new( $config });
  $pi->write_pod;

  our %_pod_inherit_config = ( skip_underscored => 0 );

package Pod::Inherit;
use warnings;
use strict;
use MRO::Compat;
our $DEBUG;
BEGIN {
  if ($DEBUG) {
    require Data::Dump::Streamer;
    Data::Dump::Streamer->import('Dump');
  }
}
use Sub::Identify;
use Pod::Compiler;
use Path::Class;
our $VERSION = '0.07';

sub new {
    my ($class, $args) = @_;
    $args = {
        'skip_underscored' => 1,
        'input_files' => [], # \@ARGV,
        'out_dir' => '',
        'class_map' => {},
        %{ $args || {} },
    };

    # Accept just a single filename in here -- OR A SINGLE Path::Class::File!
    $args->{input_files} = [$args->{input_files}] if not ref($args->{input_files}) eq 'ARRAY';

    my $self = bless($args, $class);
    return $self;
}

sub write_pod {
  my ($self) = @_;
  
  my @targets = map {
    # The origtarget needs to be a directory; if it's a file, lie and claim to the rest
    # of the code that the user passed the directory containing this file.
    -d $_ ? [$_, $_] : [$_, Path::Class::File->new($_)->dir]
  } @{ $self->{input_files} };
  
  if (!@targets) {
    die "no targets";
  }
  
  while (@targets) {
    my ($target, $origtarget) = @{shift @targets};
    
    if ($DEBUG) {
      print "target=$target origtarget=$origtarget \n";
    }
    if (-d $target) {
      #print "-d\n";
      for my $newtarget (glob "$target/*") {
        unshift @targets, [$newtarget, $origtarget];
      }
      next;
    }
    if ($target =~ m/\.pm$/) {
      my $output_filename = Path::Class::File->new($target);
      if ($self->{out_dir}) {
        my $src_rel_orig = Path::Class::File->new($target)->relative($origtarget);
        $output_filename = $src_rel_orig->absolute($self->{out_dir});
      }
      my $ret = $output_filename->dir->mkpath;
      $output_filename =~ s/\.pm$/.pod/g;
      
      if($self->is_ours($output_filename)) {
        my $allpod = $self->create_pod($target);
        # Don't create the output file if there would be nothing in it!
        if (!$allpod) {
          # warn "Not creating empty file $output_filename\n";
          next;
        }
        
        my ($outfh, $oldperm);
        if ($DEBUG) {
          print "Writing $output_filename\n";
        }
        if (not open $outfh, '>', $output_filename) {
          if ($!{EACCES} and $self->{force_permissions} ) {
            unlink $output_filename;
            $output_filename = Path::Class::File->new($output_filename);
            $oldperm = (stat($output_filename->dir))[2];
            chmod $oldperm | 0200, $output_filename->dir 
              or die "Can't chmod ".$output_filename->dir." (or write into it)";
            open $outfh, '>', $output_filename or die "Can't open $output_filename for output (even after chmodding it's parent directory): $!";
          } else {
            die "Can't open $output_filename for output: $!";
          }
        }
        
        print $outfh $allpod;
        close($outfh);
        if (defined $oldperm) {
          chmod $oldperm, $output_filename->dir or die sprintf "Can't chmod %s back to 0%o", $output_filename->dir, $oldperm;
        }
      }
    }
  }
}

sub create_pod {
  my ($self, $src) = @_;
  my $class_map = $self->{class_map};
  # Canonize src; not only does not doing it produce a minor testing & prettiness problem
  # with the generated-data comment, far more importantly, it will keep require from
  # knowing that t/lib//foo and t/lib/foo are the same library, leading to "redefined"
  # warnings.
  # (And we need to make it a string again, because otherwise Pod::Parser gets confused.)
  $src = Path::Class::File->new($src)->stringify;

#  print "handle_pmfile($src)\n";
  
  my $tt_stash;
  
  my $classname = $self->filename_to_classname($src);
  if (!$classname) {
#    print "Couldn't find any package statement in $src\n";
    return;
  }
  $tt_stash->{classname}=$classname;

  # What we had here was hack on top of hack on top of hack, and still didn't work.
  # Fuckit.  Rewrite.
  local $|=1;
  my $class_as_filename = $classname;
  $class_as_filename =~ s!::!/!g;
  $class_as_filename .= ".pm";

  my $old_sig_warn = $SIG{__WARN__};
  local $SIG{__WARN__} = sub {
    my ($warning) = @_;
    $warning = "While working on $src: $warning";
    if ($old_sig_warn) {
      $old_sig_warn->($warning);
    } else {
      warn $warning;
    }
  };

  # Just like require, except without that pesky checking @INC thing,
  # but making sure we put the "right" thing in %INC.
  if (!exists $INC{$class_as_filename}) {
    if (!do $src) {
      my $err = $@;
      $err =~ s/ \(\@INC contains: .*\)//;
      print STDERR "Couldn't autogenerate documentation for $src: $err\n";
      return;
    }
  }
  $INC{$class_as_filename} = $src;
  
  
  my @isa_flattened = @{mro::get_linear_isa($classname)};
  
  # The isa tree seems to always begin with ourself.  Fair enough, but not
  # really wanted here.
  if ($isa_flattened[0] eq $classname) {
    shift @isa_flattened;
  }
  # We can't possibly find anything.  Just short-circuit and save ourselves a lot of trouble.
  if (!@isa_flattened) {
#    print "No parent classes\n";
    return;
  }
  $tt_stash->{isa_flattened} = \@isa_flattened;
  
  my %seen;
  my @derived;
  for my $parent_class (@isa_flattened) {
    # print "$parent_class\n";
    my $stash;
    {
      no strict 'refs';
      $stash = \%{"$parent_class\::"};
    }
    #if ($parent_class eq 'DBIx::Class::Relationship::HasOne') {
    #  Dump $stash;
    #}
    # There's something subtle and brain-melting going on here, but I think it works.
    my $local_config = $stash->{_pod_inherit_config};
    #print "Parent class $parent_class\n";
    #print "local config: \n";
    #Dump $local_config;
    #print "stringy local_config: ". $local_config. "\n";
    if (not exists $local_config->{skip_underscored}) {
      $local_config->{skip_underscored} = $self->{skip_underscored};
    }
    $local_config->{class_map} ||= $class_map;

    #print "post-defaulting local config: \n";
    #Dump $local_config;
    #print "skip_underscored: $local_config->{skip_underscored}\n";
    for my $globname (sort keys %$stash) {
      if ($local_config->{skip_underscored} and $globname =~ m/^_/) {
        next;
      }
      next if $seen{$globname};
      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 probbaly imported accidentally.\n";
          $exists=0;
        } else {
          die "While checking if $parent_class $globname is a sub: $@";
        }
      }
      if (!$exists) {
        next;
      }

      # 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);
      # 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;
      }
      # print "$globname $nice_name $identify_name\n";
      # 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 = $parent_class;
      if ($local_config->{class_map}->{$parent_class}) {
        $doc_parent_class = $local_config->{class_map}->{$parent_class};
      }
      push @{$tt_stash->{methods}{$doc_parent_class}}, $nice_name;
      if (!grep {$_ eq $doc_parent_class} @isa_flattened) {
        # Hm, is there a better way of doing this?
        # We want to insert $doc_parent_class just before $parent_class in @isa_flattened.
        @isa_flattened = map {$_ eq $parent_class ? ($doc_parent_class, $_) : $_} @isa_flattened;
      }
    }
  }

  # There were parent classes, but we don't inherit any methods from them.  Don't insert an empty section.
  return if !keys %{$tt_stash->{methods}};
  
  # We used to use TT here, but TT doesn't like hash elements that have
  # names beginning with underscores.
  
  my $new_pod = <<'__END_POD__';
 
 =head1 INHERITED METHODS
 
 =over
 
 
__END_POD__
  
  # Indent, so doesn't show up as POD::Inherit's own POD.
  $new_pod =~ s/^ //mg;
  
  for my $class (@{$tt_stash->{isa_flattened}}) {
    next unless ($tt_stash->{methods}{$class});
    $new_pod .= "=item L<$class>\n\n";
    $new_pod .= join(", ", @{$tt_stash->{methods}{$class}}) . "\n\n\n";
  }

  $new_pod .= "=back\n\n";

  # Rather annoyingly, we can't just stick a bunch of POD already marked up into a Pod::Compile; it needs an object.
  $new_pod = bless {_text => $new_pod}, 'Pod::superliteral';

  my $pod = Pod::Compiler::pod_compile({ -warnings => 0, -errors => 0 }, $src)
    or die "Couldn't parse existing pod in $src";
  
  my $insertion_point;
  my $before; # If set, we should go *before* the insertion point.  Otherwise we should go *after*.
  for (reverse $pod->daughters) {
    next unless $_->isa('Pod::head');
    next unless $_->level eq 1;
    
    my $text = $_->nodetext;
    # This should be a list of all POD sections that should be "at the end of the file".
    # That is, things that we should go before.
    if (grep {$text eq $_} qw<LICENSE AUTHORS LIMITATIONS CONTRIBUTORS AUTHOR CAVEATS COPYRIGHT BUGS>, 'SEE ALSO', 'ALSO SEE', 'WHERE TO GO NEXT') {
      $insertion_point = $_;
      $before = 1;
      next;
    } else {
#      print "Found head $text, going after that section\n";
      last;
    }
  } 

  my $outstr = $self->get_inherit_header($classname, $src);
  
  if (!$insertion_point) {
    $insertion_point = ($pod->daughters)[-1];
#    print "Going at end\n";
  }
  if (!$insertion_point) {
    $insertion_point = $pod;
#    print "Going as only section\n";
    $outstr .= $new_pod->as_pod;
    return $outstr;
  } else {
    
#    print "Insertion point: $insertion_point\n";
#    print " '", $insertion_point->nodetext, "'\n"
#      if $insertion_point->isa('Pod::head');
    
    my $mother = $insertion_point->mother || $insertion_point;
    # We want to insert $new_pod just *before* $insertion_point;
    my @daughters = $mother->daughters;
    my @new_daughters;
    for (@daughters) {
      if ($_ == $insertion_point && $before) {
        push @new_daughters, $new_pod;
      }
      push @new_daughters, $_;
      if ($_ == $insertion_point && !$before) {
        push @new_daughters, $new_pod;
      }
    }
    $mother->set_daughters(@new_daughters);
    #   my $existing_pod = Pod::Tree->new;
    #   $pod_tree->load_file($src) or die "Couldn't parse original POD in $src";
    
    #   my $prev_head;
    #   for my $kid (reverse @{$pod_tree->get_root->get_children}) {
    #     Dump $kid;
    #     next unless $kid->get_type eq 'command';
    #     next unless $kid->get_command eq 'head1';
    #     my $text = $kid->get_text;
    #     $text =~ s/\s+$//;
    #     if ($text eq 'LICENSE' or
    #         $text eq 'AUTHORS') {
    #       # skip these sections, they belong at the end.
    #     } else {
    #       die "Unknown POD section $text -- is this the insertion point?";
    #     }
    #     $prev_head = $kid;
    #   }
    
    #   $prev_head
    # ... output it to ??
    $outstr .= $pod->as_pod;
    $pod->delete_tree;
    return $outstr;
  }
}

sub filename_to_classname {
  my ($self, $filename) = @_;

  open my $fh, "<", $filename or die "Can't open $filename: $!";
  
  while (<$fh>) {
    if (m/^package\s+([A-Za-z0-9_:]+);/) {
      return $1;
    }
  }
}

sub is_ours {
    my ($self, $outfn) = @_;

    # If it already exists, make sure it's one of ours
    if (-e $outfn) {
        open my $outfh, '<', $outfn
            or die "Can't open pre-existing $outfn for reading: $!";
        # FIXME: Should probably check past the first line for this, in case something else placed it's autogenerated marker before ours.
        if (<$outfh> ne "=for comment POD_DERIVED_INDEX_GENERATED\n") {
            warn "$outfn already exists, and it doesn't look like we generated it.  Skipping this file";
            return 0;
        }
#        print "Output file already exists, but seems to be one of ours, overwriting it\n";
    }

    return 1;
}


sub get_inherit_header {
    my ($self, $classname, $src) = @_;

return  <<__END_HEADER__;
=for comment POD_DERIVED_INDEX_GENERATED
The following documentation is automatically generated.  Please do not edit
this file, but rather the original, inline with $classname
at $src
(on the system that originally ran this).
If you do edit this file, and don't want your changes to be removed, make
sure you change the first line.

=cut

__END_HEADER__

}

1;

package Pod::superliteral;
use Pod::objects;
use vars '$AUTOLOAD', '@ISA';
# @ISA = ('Pod::_obj', 'Tree::DAG_Node');

sub as_pod {
  $_[0]->{_text};
}

sub AUTOLOAD {
  return if $AUTOLOAD eq 'Pod::superliteral::DESTROY';
  die "Unhandled Pod::objects API: $AUTOLOAD";
}

sub walk_down {
  my ($node, $args) = @_;
  if ($args->{callback}) {
    $args->{callback}($node, $args);
  }
  if ($args->{callbackback}) {
    $args->{callbackback}($node, $args);
  }
}

sub is_node {
  1;
}

1;