Pod::Classdoc
package Pod::Classdoc;
use PPI;
use PPI::Document;
use PPI::Find;
use File::Path;
use strict;
use warnings;
our $VERSION = '1.01';
my %validpkgtags = (qw(
author 2
deprecated 1
exports 1
ignore 1
imports 1
instance 1
member 1
see 2
self 1
since 1
));
my %validsubtags = (qw(
author 2
constructor 1
deprecated 1
ignore 1
param 1
optional 1
return 1
returnlist 1
see 2
self 1
simplex 1
since 1
static 1
urgent 1
));
my %secttags = (
'export' => '_e_',
'import' => '_i_',
'member' => '_m_',
'method' => '_f_',
'package' => '_p_'
);
#
# our default color theme; change these
# for different look
#
my $aqua = '#98B5EB';
#
# our database:
# key is class name
# contents are
# author => '',
# since => '',
# version => '',
# InheritsFrom => {},
# SubclassedBy => {},
# Description => '',
# File => '',
# Line => '',
# see => [],
# deprecated => undef|1,
# exports => [],
# imports => [],
# members => [],
# instance => '',
# self => '',
# Methods =>
# {
# $name =>
# {
# Description => '',
# File => '',
# Line => '',
# static => undef|1,
# self => '',
# deprecated => undef|1,
# see => [],
# since => '',
# param => [ 'name', 'description', ... ],
# return => 'description',
# returnlist => 'description',
# simplex => undef|1,
# urgent => undef|1,
# constructor => 1|undef
# }
# }
#
sub new {
my ($class, $path, $title, $verbose) = @_;
$path ||= './classdocs';
$path=~s/\/+$// unless ($path eq '/');
my $self = {
_path => $path,
_classes => {},
_title => $title,
_verbose => $verbose || 0,
};
return bless $self, $class;
}
sub add {
my ($self, $txt, $file) = @_;
$txt = join("\n", @$txt)
if ref $txt;
#
# grab version as for MakeMaker;
# note only one version per source file
#
my $version;
if ($txt=~/\n\s*((my|our|local)\s+)?\$[\w\:\']*?\bVERSION\s*?\=([^;]+?);/) {
eval "\$version = $3;";
}
$self->{_state} = 0;
$self->{_currpkg} = '';
$self->{_currpod} = '';
$self->{_currsub} = '';
$self->{_currloc} = undef;
$self->{_currtext} = $txt;
$self->{_currfile} = $file;
$self->{_nosubs} = 0;
my $Document = PPI::Document->new(\$txt) or die "Can't process into PPI::Document";
# Create the Find object
my $Finder = PPI::Find->new( sub { $self->_wanted(@_); } ) or die "Can't create PPI::Find";
# Use the object as an iterator
$Finder->start($Document) or die "Failed to execute search";
#
# process any trailing classdoc section
#
$self->{_nosubs} += _processClassdocs(undef, $self->{_currpod}, $self->{_currloc}, $self->{_currloc}, $file, $self->{_classes}, $self->{_currpkg})
if $self->{_currpod};
#
# process any open package
#
$self->_processPackage() if $self->{_currpkg};
warn "$self->{_nosubs} classdoc sections found without matching methods."
if $self->{_nosubs} && $self->{_verbose};
if ($self->{_verbose} > 1) {
foreach my $currpkg (sort keys %{$self->{_classes}}) {
my $pkg = $self->{_classes}{$currpkg};
print "Package $currpkg at line $pkg->{File}:$pkg->{Line}:\n$pkg->{Description}\n\nhas the following methods:\n\n";
my $sub;
$sub = $pkg->{Methods}{$_},
print "**********\n$_ at line $sub->{File}:$sub->{Line}:\n$sub->{Description}\n\n"
foreach (sort keys %{$pkg->{Methods}});
}
}
return $Document;
}
sub open {
my ($self, $path, $pkg) = @_;
my $file = $pkg ? "$path/$pkg" : $path;
$file=~s/::/\//g;
$file .= '.pm' if $pkg;
$@ = "Cannot open $file: $!" and
return undef
unless open(INF, $file);
my $oldsep = $/;
$/ = undef;
my $doc = <INF>;
close INF;
$/ = $oldsep;
return $self->add($doc, $file);
}
sub openProject {
my $self = shift;
$self->_getSubDirs($_)
foreach @_;
my $dirs = $self->{_dirs};
print "Scanning ", join("\n", @$dirs), "\n"
if $self->{_verbose};
my @files = ();
foreach my $path (@$dirs) {
unless (opendir(PATH, $path)) {
warn "directory $path not found"
if $self->{_verbose};
next;
}
#
# glob the directory for all .pm files;
#
my @tfiles = readdir PATH;
closedir PATH;
push @files, map "$path/$_", grep /\.pm$/, @tfiles;
}
foreach (@files) {
return undef
unless $self->open($_);
}
return $self;
}
sub _processClassdocs {
my ($currsub, $currpod, $podloc, $subloc, $file, $packages, $currpkg) = @_;
#
# collect all classdocs first, there may be a list of @xs before a real sub
#
my @classdocs = $currpod ?
($currpod=~/\n=begin\s+classdoc[ \r\t]*\n(.*?)\n=end\s+classdoc[ \r\t]*\n/gs) :
();
if ($currsub) {
#
# if a real sub, grab the last one...but make sure it isn't for @xs
#
$currpod = pop @classdocs;
if ((!$currpod) || ($currpod=~/\n\s*\@xs\s+/)) {
push @classdocs, $currpod if $currpod;
_processSub($currsub, undef, $subloc, $file, $packages, $currpkg);
}
else {
_processSub($currsub, $currpod, $subloc, $file, $packages, $currpkg);
}
}
my $nosubs = 0;
foreach (@classdocs) {
#
# flag unexpected classdocs
#
if (s/\n\s*\@xs\s+([\w\:]+)[ \t\r]*\n/\n/s) {
_processSub($1, $_, $podloc, $file, $packages, $currpkg);
}
else {
$nosubs++;
}
}
return $nosubs;
}
sub _processSub {
my ($currsub, $currpod, $subloc, $file, $packages, $currpkg) = @_;
#
# need to check for fully qualified sub name
#
my @parts = split /\:\:/, $currsub;
if (@parts > 1) {
$currsub = pop @parts;
$currpkg = join('::', @parts);
}
$packages->{$currpkg} = {
File => '',
Line => 0,
Description => undef,
Methods => {}
}
unless exists $packages->{$currpkg};
if (exists $packages->{$currpkg}{Methods}{$currsub}) {
$packages->{$currpkg}{Methods}{$currsub}{File} = $file,
$packages->{$currpkg}{Methods}{$currsub}{Line} = $subloc,
$packages->{$currpkg}{Methods}{$currsub}{Description} = $currpod
unless $packages->{$currpkg}{Methods}{$currsub}{File};
}
else {
$packages->{$currpkg}{Methods}{$currsub} = {
File => $file,
Line => $subloc,
Description => $currpod
};
}
}
sub _wanted {
my ($self, $token, $parent) = @_;
print "*** Got a ", ref $token, "\n"
if ($self->{_verbose} > 2) && ($token->significant || $token->isa('PPI::Token::Pod'));
return 0 if ($self->{_state} == 0) && (!$token->isa('PPI::Token::Pod'));
my $content;
if ($self->{_state} == 0) {
$content = $token->content;
return 0 unless $content=~/\n=begin\s+classdoc[ \r\t]*\n.*?\n=end\s+classdoc[ \r\t]*\n/s;
print "** Process a new POD\n"
if ($self->{_verbose} > 1);
$self->{_currpod} = $content;
$self->{_currloc} = ${$token->location}[0];
$self->{_state} = 1;
}
elsif ($self->{_state} == 1) {
#
# we'll support dangling classdocs and nested POD (have to, to support @xs!)
#
if ($token->isa('PPI::Token::Pod')) {
$content = $token->content;
return 0 unless $content=~/\n=begin\s+classdoc[ \r\t]*\n.*?\n=end\s+classdoc[ \r\t]*\n/s;
#
# process prior classdoc section
#
print "** Process a new dangling POD\n"
if ($self->{_verbose} > 1);
$self->{_nosubs} += _processClassdocs(undef, $self->{_currpod}, $self->{_currloc}, $self->{_currloc}, $self->{_currfile}, $self->{_classes}, $self->{_currpkg});
$self->{_currpod} = $1;
$self->{_currloc} = ${$token->location}[0];
}
elsif ($token->isa('PPI::Statement::Package')) {
print "** Process a Package\n"
if ($self->{_verbose} > 1);
#
# if a prior namespace defined, save its body and recover any
# inheritance info; we should really try to use PPI here...
#
$self->_processPackage(${$token->location}[0])
if $self->{_currpkg};
$self->{_currpkg} = $token->namespace;
if (exists $self->{_classes}{$self->{_currpkg}}) {
$self->{_classes}{$self->{_currpkg}}{File} = $self->{_currfile},
$self->{_classes}{$self->{_currpkg}}{Line} = ${$token->location}[0],
$self->{_classes}{$self->{_currpkg}}{Description} =
($self->{_currpod} && $self->{_currpod}=~/\n=begin\s+classdoc[ \r\t]*\n(.*?)\n=end\s+classdoc[ \r\t]*\n/gs) ? $1 : undef
unless $self->{_classes}{$self->{_currpkg}}{File};
}
else {
$self->{_classes}{$self->{_currpkg}} = {
File => $self->{_currfile},
Line => ${$token->location}[0],
Description => ($self->{_currpod} && $self->{_currpod}=~/\n=begin\s+classdoc[ \r\t]*\n(.*?)\n=end\s+classdoc[ \r\t]*\n/gs) ? $1 : undef,
Methods => {}
};
}
$self->{_currpod} = '';
$self->{_currloc} = undef;
$self->{_state} = 0;
}
elsif ($token->isa('PPI::Statement::Sub')) {
die "Unexpected sub $content at line " . ${$token->location}[0]
unless $self->{_currpkg};
print "** Process a Sub\n"
if ($self->{_verbose} > 1);
$self->{_nosubs} += _processClassdocs($token->name, $self->{_currpod}, $self->{_currloc}, ${$token->location}[0], $self->{_currfile}, $self->{_classes}, $self->{_currpkg});
$self->{_currpod} = '';
$self->{_currloc} = undef;
$self->{_state} = 0;
}
}
return 1;
}
sub _processPackage {
my ($self, $end) = @_;
#
# if a prior namespace defined, save its body and recover any
# inheritance info; we should really try to use PPI here...
#
my $pkg = $self->{_classes}{$self->{_currpkg}};
my $txt = "\n" .
(defined $end ?
substr($self->{_currtext}, $pkg->{Line}, $end - $pkg->{Line}) :
substr($self->{_currtext}, $pkg->{Line}));
my @parents = ($txt=~/\n\s*use\s+base\s+([^;]+);/gs);
foreach my $base (@parents) {
my @bases = ();
eval "\@bases = $base;";
map $pkg->{InheritsFrom}{$_} = 1, @bases;
}
@parents = ($txt=~/\n\s*(?:(?:my|our)\s+)?\@ISA\s+=\s+([^;]+);/gs);
foreach my $base (@parents) {
my @bases = ();
eval "\@bases = $base;";
map $pkg->{InheritsFrom}{$_} = 1, @bases;
}
}
sub path {
my ($self, $path) = @_;
return $self->{_path} unless $path;
$path=~s/\/+$// unless ($path eq '/');
my $old = $self->{_path};
$self->{_path} = $path;
return $old;
}
sub render {
my ($self, $use_private) = @_;
my $descr;
my $version = '';
my $accum = '';
my $indoc;
my $inpod;
my $classes = $self->{_classes};
my ($class, $content);
my $path = $self->{_path};
#
# now create crossref of inherits/subclasses
#
foreach $class (keys %$classes) {
foreach (keys %$classes) {
$classes->{$class}{SubclassedBy}{$_} = 1
if exists $classes->{$_}{InheritsFrom}{$class};
}
}
#
# parse each description for tags
#
my ($method, $info);
foreach $class (keys %$classes) {
if ($classes->{$class}{Description}) {
$self->_parseTags($class, $classes->{$class}, \%validpkgtags);
}
elsif ($self->{_verbose} > 1) {
warn "No classdoc for $class\n";
}
while (($method, $info) = each %{$classes->{$class}{Methods}}) {
if ($info->{Description}) {
$self->_parseTags($class, $info, \%validsubtags);
}
elsif ($self->{_verbose} > 1) {
warn "No classdoc for $class\::$method\n";
}
}
}
my %classlist;
$classlist{$_} = $self->_generateDoc($_, $path, $use_private)
foreach (keys %$classes);
return \%classlist;
}
sub clear {
my $self = shift;
$self->{_classes} = {};
return $self;
}
sub writeFrameContainer {
my ($self, $container, $home) = @_;
my $path = $self->{_path};
$@ = "Can't open $path/$container: $!",
return undef
unless CORE::open(OUTF, ">$path/$container");
print OUTF $self->getFrameContainer($home);
close OUTF;
return $self;
}
sub getFrameContainer {
my ($self, $home) = @_;
my $path = $self->{_path};
my $title = $self->{_title};
return $home ?
"<html><head><title>$title</title></head>
<frameset cols='15%,85%'>
<frame name='navbar' src='toc.html' scrolling=auto frameborder=0>
<frame name='mainframe' src='$home'>
</frameset>
</html>
" :
"<html><head><title>$title</title></head>
<frameset cols='15%,85%'>
<frame name='navbar' src='toc.html' scrolling=auto frameborder=0>
<frame name='mainframe'>
</frameset>
</html>
";
}
sub writeTOC {
my $self = shift;
my $path = $self->{_path};
$@ = "Can't open $path/toc.html: $!",
return undef
unless CORE::open(OUTF, ">$path/toc.html");
print OUTF $self->getTOC(@_);
close OUTF;
return $self;
}
sub getTOC {
my $self = shift;
my @order = @_;
my $path = $self->{_path};
my $title = $self->{_title};
my $base;
my $doc =
"<html>
<body>
<small>
<!-- INDEX BEGIN -->
<ul>
";
my %ordered = ();
$ordered{$_} = 1 foreach (@order);
foreach (sort keys %{$self->{_classes}}) {
push @order, $_ unless exists $ordered{$_};
}
foreach my $class (@order) {
#
# due to input @order, we might get classes that don't exist
#
next unless exists $self->{_classes}{$class};
$base = $class;
$base =~s/::/\//g;
$doc .= "<li><a href='$base.html' target='mainframe'>$class</a>
<ul>
<li><a href='$base.html#summary' target='mainframe'>Summary</a></li>
";
my $info = $self->{_classes}{$class};
my %t;
my ($k, $v);
if (exists $info->{exports} && @{$info->{exports}}) {
$doc .= "<li><a href='$base.html#exports' target='mainframe'>Exports</a>
<ul>
";
%t = @{$info->{exports}};
$doc .= "<li><a href='$base.html#_e_$_' target='mainframe'>$_</a></li>\n"
foreach (sort keys %t);
$doc .= "</ul>\n</li>\n";
}
if (exists $info->{imports} && @{$info->{imports}}) {
$doc .= "<li><a href='$base.html#imports' target='mainframe'>Imports</a>
<ul>
";
%t = @{$info->{imports}};
$doc .= "<li><a href='$base.html#_i_$_' target='mainframe'>$_</a></li>\n"
foreach (sort keys %t);
$doc .= "</ul>\n</li>\n";
}
if (exists $info->{member} && @{$info->{member}}) {
$doc .= "<li><a href='$base.html#members' target='mainframe'>Public Members</a>
<ul>
";
%t = @{$info->{member}};
$doc .= "<li><a href='$base.html#_m_$_' target='mainframe'>$_</a></li>\n"
foreach (sort keys %t);
$doc .= "</ul>\n</li>\n";
}
if (exists $info->{constructors} && %{$info->{constructors}}) {
$doc .= "<li><a href='$base.html#constructor_detail' target='mainframe'>Constructors</a>
<ul>
";
$doc .= "<li><a href='$base.html#_f_$_' target='mainframe'>$_</a></li>\n"
foreach (sort keys %{$info->{constructors}});
$doc .= "</ul>\n</li>\n";
}
if (exists $info->{Methods} && %{$info->{Methods}}) {
$doc .= "<li><a href='$base.html#method_detail' target='mainframe'>Methods</a>
<ul>
";
$doc .= "<li><a href='$base.html#_f_$_' target='mainframe'>$_</a></li>\n"
foreach (sort keys %{$info->{Methods}});
$doc .= "</ul>\n</li>\n";
}
$doc .= "</ul>\n</li>\n";
}
$doc .= "
</ul>
<!-- INDEX END -->
</small>
</body>
</html>
";
return $doc;
}
sub writeClassdocs {
my ($self, $use_private) = @_;
my $classdocs = $self->render($use_private)
or return undef;
my $path = $self->{_path};
foreach (sort keys %$classdocs) {
my $fname = $self->makeClassPath($_);
$@ = "Cannot open $fname: $!",
return undef
unless CORE::open(OUTF, ">$fname");
print OUTF $classdocs->{$_}[0];
close(OUTF);
$classdocs->{$_}[0] = $fname;
}
return $classdocs;
}
sub makeClassPath {
my ($self, $class) = @_;
my $path = $self->{_path};
$class=~s!::!/!g;
$class = join('/', $path, $class);
my ($dir) = ($class=~/^(.*)\/[^\/]+$/);
mkpath $dir
unless -d $dir;
return "$class.html";
}
sub _generateDoc {
my ($self, $class, $path, $use_private) = @_;
my $info = $self->{_classes}{$class};
my @parts = split /\:\:/, $class;
my $fname = pop @parts;
my $dir = @parts ? join('/', @parts) : '';
#
# create nav path prefix
#
my $pfxcnt = 1 + ($dir=~tr'/'');
my $pathpfx = '../' x $pfxcnt;
my ($constrsum, $constrdet, $methsum, $methdet) =
(
"<a href='#constructor_summary'>CONSTR</a>",
"<a href='#constructor_detail'>CONSTR</a>",
"<a href='#method_summary'>METHOD</a>",
"<a href='#method_detail'>METHOD</a>"
);
my $doc = "
<html>
<head>
<title>$class</title>
</head>
<body>
<table width='100%' border=0 CELLPADDING='0' CELLSPACING='3'>
<TR>
<TD VALIGN='top' align=left><FONT SIZE='-2'>
SUMMARY: $constrsum | $methsum
</FONT></TD>
<TD VALIGN='top' align=right><FONT SIZE='-2'>
DETAIL: $constrdet | $methdet
</FONT></TD>
</TR>
</table><hr>
<h2>Class $class</h2>
";
#
# process InheritsFrom
#
my $base;
my @bases = ();
foreach (keys %{$info->{InheritsFrom}}) {
$base = $_;
$base=~s/::/\//g;
# $base=~s/^$dir\///; # remove matching headers
push @bases, "<a href='$pathpfx$base.html'>$_</a>";
}
$doc .= "
<p>
<dl>
<dt><b>Inherits from:</b>
<dd>" . join("</dd>\n<dd>", @bases) . "</dd>
</dt>
</dl>
"
if scalar @bases;
#
# process SubclassedBy
#
@bases = ();
foreach (keys %{$info->{SubclassedBy}}) {
$base = $_;
$base=~s/::/\//g;
# $base=~s/^$dir\///; # remove matching headers
push @bases, "<a href='$pathpfx$base.html'>$_</a>";
}
$doc .= "
<p>
<dl>
<dt><b>Known Subclasses:</b>
<dd>" . join("</dd>\n<dd>", @bases) . "</dd>
</dt>
</dl>
"
if scalar @bases;
#
# process package tags
#
$doc .= '
<hr>
';
$doc .= "<b>Deprecated.</b>" .
(($info->{deprecated} ne '1') ? " <i>$info->{deprecated}</i>\n" : "\n") .
"<p>\n"
if $info->{deprecated};
$doc .= "
$info->{Description}
<p>
"
if $info->{Description};
$doc .= '
<dl>
';
$doc .= "
<dt><b>Author:</b></dt>
<dd>$info->{author}</dd>
"
if $info->{author};
$doc .= "
<dt><b>Version:</b></dt>
<dd>$info->{Version}</dd>
"
if $info->{Version};
$doc .= "
<dt><b>Since:</b></dt>
<dd>$info->{since}</dd>
"
if $info->{since};
$doc .= join('', "
<dt><b>See Also:</b></dt>
<dd>", _makeSeeLinks($info->{see}, $pathpfx), "</dd>
")
if $info->{see};
$doc .= "
<p>
<i>Class instances are $info->{instance} references.</i>
<p>"
if $info->{instance};
$doc .= "
<p>
<i>Unless otherwise noted, <code>$info->{self}</code> is the object instance variable.</i>
<p>"
if $info->{self};
#
# process imports
#
$doc .= join('', "
<a name='imports'></a>
<table border=1 cellpadding=3 cellspacing=0 width='100%'>
<tr bgcolor='$aqua'><th colspan=2 align=left><font size='+2'>Imported Symbols</font></th></tr>
", _makeExportDesc($info->{imports}, '_i_'), "
</table>
<p>
")
if $info->{imports};
#
# process exports
#
$doc .= join('', "
<a name='exports'></a>
<table border=1 cellpadding=3 cellspacing=0 width='100%'>
<tr bgcolor='$aqua'><th colspan=2 align=left><font size='+2'>Exported Symbols</font></th></tr>
", _makeExportDesc($info->{exports}, '_e_'), "
</table>
<p>
")
if $info->{exports};
#
# process members
#
$doc .= join('', "
<a name='members'></a>
<table border=1 cellpadding=3 cellspacing=0 width='100%'>
<tr bgcolor='$aqua'><th colspan=2 align=left><font size='+2'>Public Instance Members</font></th></tr>
", _makeExportDesc($info->{member}, '_m_'), "
</table>
<p>
")
if $info->{member};
#
# collect method map info before processing
#
my %methodmap = ();
while (my($sub, $methodinfo) = each %{$info->{Methods}}) {
$methodmap{$sub} = [ $methodinfo->{File}, $methodinfo->{Line} ]
unless (!$use_private) &&
(substr($sub, 0, 1) eq '_') &&
(!$methodinfo->{constructor});
}
#
# process constructors. Scan for methods with descriptions with '@constructor'
#
$doc .= "
<a name='summary'></a>
";
my %constructors = ();
my $constructor;
my $anchored;
foreach (sort keys %{$info->{Methods}}) {
next
unless exists $info->{Methods}{$_}{constructor};
$anchored = 1,
$doc .= "
<a name='constructor_summary'></a>
",
unless $anchored;
$doc .= "
<table border=1 cellpadding=3 cellspacing=0 width='100%'>
<tr bgcolor='$aqua'><th align=left><font size='+2'>Constructor Summary</font></th></tr>
"
unless $constructor;
$constructor = $constructors{$_} = delete $info->{Methods}{$_};
$doc .= join('', "
<tr><td align=left valign=top>
<code><a href='#_f_$_'>$_</a>", _makeParamList($constructor->{param}), "</code>
");
if ($constructor->{deprecated}) {
$doc .= '
<BR>
<B>Deprecated.</B> ' .
(($constructor->{deprecated} ne '1') ? "<i>$constructor->{deprecated}</i>" : '');
}
elsif ($constructor->{Description}) {
my $descr = $constructor->{Description};
my $brief = _briefDescription(($descr=~/^\s*Constructor\.\s*(.*)$/s) ? $1 : $descr);
$doc .= "
<BR>
$brief
";
}
$doc .= "</td></tr>\n";
} # end for constructors
$info->{constructors} = \%constructors;
if ($constructor) {
$doc .= "</table><p>\n"
}
else {
$doc=~s!<a href='#constructor_summary'>CONSTR</a>!CONSTR!;
$doc=~s!<a href='#constructor_detail'>CONSTR</a>!CONSTR!;
}
#
# process methods
#
my @methods = sort keys %methodmap;
my $methcount = @methods;
if ($methcount) {
$doc .= "
<a name='method_summary'></a>
<table border=1 cellpadding=3 cellspacing=0 width='100%'>
<tr bgcolor='$aqua'><th align=left><font size='+2'>Method Summary</font></th></tr>
";
foreach (@methods) {
my $method = $info->{Methods}{$_};
$doc .= join('', "
<tr><td align=left valign=top>
<code><a href='#_f_$_'>$_</a>", _makeParamList($method->{param}), "</code>
");
if ($method->{deprecated}) {
$doc .= '
<BR>
<B>Deprecated.</B> ' .
(($method->{deprecated} ne '1') ? "<i>$method->{deprecated}</i>" : '');
}
elsif ($method->{Description}) {
my $descr = ($method->{static} ? "<i>(class method)</i> " : '') . $method->{Description};
my $brief = _briefDescription($descr);
$doc .= "
<BR>
$brief
";
}
$doc .= "</td></tr>\n";
}
$doc .= "</table>
<p>
";
}
else {
$doc=~s!<a href='#method_summary'>METHOD</a>!METHOD!;
$doc=~s!<a href='#method_detail'>METHOD</a>!METHOD!;
}
if (keys %constructors) {
$doc .= "
<a name='constructor_detail'></a>
<table border=1 cellpadding=3 cellspacing=0 width='100%'>
<tr bgcolor='$aqua'>
<th align=left><font size='+2'>Constructor Details</font></th>
</tr>
</table>
";
foreach (sort keys %constructors) {
my $method = $constructors{$_};
my $returns = $method->{return};
my $descr = $method->{Description} || ' ';
$descr=~s/^\s*Constructor\.\s*//;
$doc .= join('', "
<a name='_f_$_'></a>
<h3>$_</h3>
<pre>
$_", _makeParamList($method->{param}), "
</pre><p>
<dl>
<dd>$descr
<p>
<dd><dl>
");
$doc .= join('', "<dt><b>Parameters:</b>\n", _makeParamDesc($method->{param}))
if $method->{param};
$doc .= "<dt><b>Returns:</b><dd>$returns</dd>\n"
if $returns;
$doc .= "<dt><b>Since:</b></dt><dd>$method->{since}</dd>\n"
if $method->{since};
$doc .= join('', "<dt><b>See Also:</b></dt><dd>", _makeSeeLinks($method->{see}, $pathpfx), "</dd>\n")
if $method->{see};
$doc .= "</dl></dd></dl><hr>\n";
}
$doc .= "\n<p>\n";
} # end if constructor
if ($methcount) {
$doc .= "
<a name='method_detail'></a>
<table border=1 cellpadding=3 cellspacing=0 width='100%'>
<tr bgcolor='$aqua'>
<th align=left><font size='+2'>Method Details</font></th>
</tr></table>
";
foreach (@methods) {
my $method = $info->{Methods}{$_};
my $returns = $method->{return};
my $returnlist = $method->{returnlist};
my $descr = ($method->{static} ? "<i>(class method)</i> " : '') .
($method->{Description} || ' ');
$doc .= join('', "
<a name='_f_$_'></a>
<h3>$_</h3>
<pre>
$_", _makeParamList($method->{param}), "
</pre><p>
<dl>
<dd>$descr
<p>
<dd><dl>
");
if ($method->{simplex}) {
$doc .= ($method->{urgent} ?
"<dt><b>Simplex, Urgent</b></dt>\n" :
"<dt><b>Simplex</b></dt>\n");
}
elsif ($method->{urgent}) {
$doc .= "<dt><b>Urgent</b></dt>\n";
}
$doc .= join('', "<dt><b>Parameters:</b>\n", _makeParamDesc($method->{param}))
if $method->{param};
if ($returns) {
$doc .= ($returnlist ?
"<dt><b>In scalar context, returns:</b><dd>$returns</dd>\n" :
"<dt><b>Returns:</b><dd>$returns</dd>\n");
}
$doc .= ($returns ?
"<dt><b>In list context, returns:</b><dd>($returnlist)</dd>\n" :
"<dt><b>Returns:</b><dd>($returnlist)</dd>\n")
if $returnlist;
$doc .= "<dt><b>Since:</b></dt><dd>$method->{since}</dd>\n"
if $method->{since};
$doc .= join('', "<dt><b>See Also:</b></dt><dd>", _makeSeeLinks($method->{see}, $pathpfx), "</dd>\n")
if $method->{see};
$doc .= "</dl></dd></dl><hr>\n";
} # end foreach method
} # end if methods
#
# finish up
#
my $tstamp = scalar localtime();
$doc .= "
<small>
<center>
<i>Generated by POD::ClassDoc $VERSION on $tstamp</i>
</center>
</small>
</body>
</html>
";
return [ $doc, $info->{File}, $info->{Line}, \%methodmap ];
}
#
# generate a path from a class, along with
# an updir path from the class
#
sub _pathFromClass {
my $class = shift;
my @parts = split /\:\:/, $class;
pop @parts;
return ( '../' x (scalar @parts), join('/', @parts));
}
sub _parseTags {
my ($self, $class, $info, $validtags) = @_;
#
# expand all <cpan>, <member>, <method>, and <package> tags
# NOTE: need a nesting level to construct updir prefixes
#
my ($updir, $path) = _pathFromClass($class);
my @parts = ();
my $method;
$updir ||= '';
$info->{Description}=~s!<cpan>([^<]+)</cpan>!<a href='http://search.cpan.org/perldoc\?$1'>$1</a>!g;
$info->{Description}=~s!<(export|import|method|member)>(\w+)</(?:export|import|method|member)>!<a href='#$secttags{$1}$2'>$2</a>!g;
$info->{Description}=~s!<(export|import|method|member|package)>([\w\:]+)</(?:export|import|method|member|package)>!
{ @parts = split('\:\:', $2); $method = ($1 eq 'package') ? '' : pop @parts;
"<a href='$updir" . join('/', @parts) . '.html' . (($1 eq 'package') ? '' : "#$secttags{$1}") . "$method'>$2</a>" }!egx;
#
# process classdoc sections
#
my $desc = '';
my @lines = split /\n/, $info->{Description};
my $tag = 'Description';
my $param;
my ($ttag, $tdesc);
my $sep = "\n";
foreach (@lines) {
s/^#\*?\s*//;
$desc .= "$_$sep",
next
unless /^\@(\w+)(\s+(.*))?$/ && $validtags->{$1};
($ttag, $tdesc) = ($1, $3);
if (($tag eq 'param') || ($tag eq 'optional') || ($tag eq 'exports') || ($tag eq 'imports') || ($tag eq 'member')) {
($param, $desc) = ($desc=~/^\s*((?:[\\]?[\$\%\@\*\&])?[\w\:]+)\s*(.*)$/s);
$tag = 'param',
$desc = '<i>(optional)</i>' . $desc
if ($tag eq 'optional');
push @{$info->{$tag}}, $param, $desc;
}
elsif ($tag eq 'see') {
push @{$info->{$tag}}, $desc;
}
else {
chop $desc, chop $desc if ($sep ne "\n");
$info->{$tag} = $desc;
}
$tag = $ttag;
$desc = $tdesc || 1;
$sep = ($validtags->{$tag} == 1) ? "\n" : ",\n";
$desc .= $sep;
}
#
# don't forget the last one!
#
if (($tag eq 'param') || ($tag eq 'optional') || ($tag eq 'exports') || ($tag eq 'imports') || ($tag eq 'member')) {
($param, $desc) = ($desc=~/^\s*((?:[\\]?[\$\%\@\*\&])?[\w\:]+)\s*(.*)$/s);
$tag = 'param',
$desc = '<i>(optional)</i>' . $desc
if ($tag eq 'optional');
push @{$info->{$tag}}, $param, $desc;
}
elsif ($tag eq 'see') {
push @{$info->{$tag}}, $desc;
}
else {
chop $desc, chop $desc if ($sep ne "\n");
$info->{$tag} = $desc;
}
}
sub _makeParamList {
my $params = shift;
my $p = '(';
my $t;
my $i = 0;
$t = $params->[$i++],
$i++,
$p .= ($t=~/^[\\]?[\$\%\@\*\&]/) ? "$t, " : "$t => <i>value</i>, "
while ($i < $#$params);
chop $p,
chop $p
if (length($p) > 1);
return "$p)";
}
sub _makeParamDesc {
my $params = shift;
my $p = '<dd><table border=0>';
my ($t, $d, $sep);
my $i = 0;
$t = $params->[$i++],
$d = $params->[$i++],
$sep = ($t=~/^[\\]?[\$\%\@\*\&]/) ? ' - ' : ' => ',
$p .= "<tr><td align=left valign=top><code>$t</code></td><td valign=top align=center>$sep</td><td align=left>$d</td></tr>\n"
while ($i < $#$params);
return $p . "</table></dd>\n";
}
sub _makeExportDesc {
my ($params, $pfx) = @_;
my $p = '';
my %t = @$params;
return join("\n",
map "<tr><td align=right valign=top><a name='$pfx$_'></a><code>$_</code></td><td align=left valign=top>$t{$_}</td></tr>", sort keys %t) . "\n";
}
sub _getSubDirs {
my ($self, $path) = @_;
$@ = "$path directory not found",
return undef
unless opendir(PATH, $path);
push @{$self->{_dirs}}, $path;
#
# glob the directory for all subdirs
#
my @files = readdir PATH;
closedir PATH;
foreach (@files) {
push(@{$self->{_dirs}}, "$path/$_")
if ($_ ne '.') && ($_ ne '..') && (-d "$path/$_");
}
return $self;
}
sub _makeSeeLinks {
$_[0][-1]=~s/,\n$/\n/;
return join("<br>\n", @{$_[0]}) . "\n";
}
sub _briefDescription {
my $descr = shift;
while ($descr=~/\G.*?((?:<a [^>]*>[^<]*<\/a>)|\.|\?|\!)/igcs) {
return substr($descr, 0, $+[1]) if ($1 eq '.') || ($1 eq '?') || ($1 eq '!');
}
return $descr;
}
1;