File Coverage

blib/lib/Pod/Classdoc.pm

Criterion	Covered	Total	%
statement	371	471	78.7
branch	151	260	58.0
condition	53	95	55.7
subroutine	29	33	87.8
pod	0	13	0.0
total	604	872	69.2

=pod

=begin classdoc

Generate javadoc-like class documentation from embedded POD.
Uses PPI::Find to locate POD, packages, and methods, then
processes the extracted POD into a javadoc-ish HTML format. Classdoc POD
is defined within =begin classdoc and
=end classdoc sections. Each such section is associated
with its immediately succeding package or method statement, unless
the @xs directive is specified, in which case
the classdoc is assumed to be for an external (e.g., XS) method.
Multiple external method classdoc sections may be specified within a single
=pod ... =cut section, with the final such classdoc section
associated with any trailing method definition.

@author Dean Arnold
@see PPI
@see PPI::Find
@see "How to Write Doc Comments for the Javadoc Tool"
@since 2007-Jun-10
@instance hash
@self $self

=end classdoc

=cut

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
#				}
#			}
#

=pod

=begin classdoc

Creates a new empty Pod::Classdoc object.

@constructor

@optional $path directory path for output documents; default is './classdocs'
@optional $title title string to use for head of classdocs
@optional $verbose if true, enables diagnostic output (default false)

@return	a new Pod::Classdoc object

=end classdoc

=cut

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;
}

=pod

=begin classdoc

Scan the provided text for Perl packages, adding the packages
to the current collection of classes. When a package is located,
it is scanned for its inherited classes and classdoc'd methods.

@param $txt	the package text as either a scalar string, or an arrayref of
	the lines of the package
@optional $file full path of source file

@return the PPI::Document object generated from the input text

=end classdoc

=cut

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;
}

=pod

=begin classdoc

Load the specified package file.

@param $path	path to the package file.
@param $pkg		Perl name of the package

@return the PPI::Document object generated from the input file

=end classdoc

=cut

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 = ;
	close INF;
	$/ = $oldsep;

	return $self->add($doc, $file);
}

=pod

=begin classdoc

Load all the package files within a specified project directory.
Recurses into subdirectories as needed.

@param @projects	list of pathnames of root project directories

@return this Pod::Classdoc object

=end classdoc

=cut

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;
	}
}

=pod

=begin classdoc

Get or set the output directory path for rendered documents.

@optional $path	root directory where classdocs are to be written; if not provided,
		a Get operation is executed

@returns	for a Get operation, the current output path;
			for a Set operation, the prior output path

=end classdoc

=cut

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

	return $self->{_path} unless $path;
	$path=~s/\/+$// unless ($path eq '/');
	my $old = $self->{_path};
	$self->{_path} = $path;
	return $old;
}

=pod

=begin classdoc

Render the loaded packages into classdocs. Creates
subdirectories for subordinate classdocs as needed.
Package files containing multiple package definitions
will result in individual files for each package.

@optional $use_private	include private methods. By default,
	only public methods are included in the output; setting this flag
	causes any documented private methods (methods beginning with an
	underscore) to be included as well. Note that constructors
	are always considered public.

@returns	on success, a hashref mapping classnames to an arrayref
			of the classdoc formatted output, the input source file name and line number
			of the class's associated classdoc'd package definition, and
			a hashref mapping method names to an arrayref of source file name and
			linenumber;
			undef on failure, with error message in $@

=end classdoc

=cut

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;
}

=pod

=begin classdoc

Clear this object. Removes all currently loaded packages.

@return	this object

=end classdoc

=cut

sub clear {
	my $self = shift;

	$self->{_classes} = {};
	return $self;
}

=pod

=begin classdoc

Write out a toplevel container document for the TOC and
classdoc frames. Assumes the TOC is named 'toc.html'.

@param $container name of output file without path; path is taken
	from the path specified via new() or
	path()
@optional $home	pathname of a toplevel document to be included in index

@return	this object on success, undef on failure, with error message in $@

=end classdoc

=cut

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;
}

=pod

=begin classdoc

Generate a toplevel container document for the TOC and
classdoc frames. Assumes the TOC is named 'toc.html'.

@optional $home	pathname of a toplevel document to be included in index

@return	the frame container document

=end classdoc

=cut

sub getFrameContainer {
	my ($self, $home) = @_;

	my $path = $self->{_path};
	my $title = $self->{_title};

	return $home ?
"$title





" :
"$title





";

}

=pod

=begin classdoc

Write out an table of contents document for the current collection of
classdocs as a nested HTML list. The output filename is 'toc.html'.
The caller may optionally specify the order of classes in the menu.

@optional @order	list of packages in the order in which they should appear in TOC; if a partial list,
					any remaining packages will be appended to the TOC in alphabetical order
@return	this object on success, undef on failure, with error message in $@

=end classdoc

=cut

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;
}

=pod

=begin classdoc

Generate a table of contents document for the current collection of
classdocs as a nested HTML list. Caller may optionally specify
the order of classes in the menu.

@optional @order	list of packages in the order in which they should appear in TOC; if a partial list,
					any remaining packages will be appended to the TOC in alphabetical order
@return	the TOC document

=end classdoc

=cut

sub getTOC {
	my $self = shift;

	my @order = @_;
	my $path = $self->{_path};
	my $title = $self->{_title};
	my $base;
	my $doc =
"




";
	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 .=  "$class

		Summary
		";
		my $info = $self->{_classes}{$class};
		my %t;
		my ($k, $v);
		if (exists $info->{exports} && @{$info->{exports}}) {
			$doc .=  "Exports

			";
			%t = @{$info->{exports}};
			$doc .=  "$_\n"
				foreach (sort keys %t);
			$doc .=  "\n\n";
		}
		if (exists $info->{imports} && @{$info->{imports}}) {
			$doc .=  "Imports

			";
			%t = @{$info->{imports}};
			$doc .=  "$_\n"
				foreach (sort keys %t);
			$doc .=  "\n\n";
		}
		if (exists $info->{member} && @{$info->{member}}) {
			$doc .=  "Public Members

			";
			%t = @{$info->{member}};
			$doc .=  "$_\n"
				foreach (sort keys %t);
			$doc .=  "\n\n";
		}
		if (exists $info->{constructors} && %{$info->{constructors}}) {
			$doc .=  "Constructors

			";
			$doc .=  "$_\n"
				foreach (sort keys %{$info->{constructors}});
			$doc .=  "\n\n";
		}
		if (exists $info->{Methods} && %{$info->{Methods}}) {
			$doc .=  "Methods

			";
			$doc .=  "$_\n"
				foreach (sort keys %{$info->{Methods}});
			$doc .=  "\n\n";
		}
		$doc .=  "\n\n";
	}

	$doc .=  "





";

	return $doc;
}

=pod

=begin classdoc

Write out the documents for the current collection of
classdocs. Renders the current set of classdocs before
writing.

@optional $use_private	include private methods. By default,
	only public methods are included in the output; setting this flag
	causes any documented private methods (methods beginning with an
	underscore) to be included as well. Note that constructors
	are always considered public.

@return	undef on failure, with error message in $@; otherwise, a hashref
	mapping classnames to an arrayref of the full pathname of the classdoc formatted output file,
	the input source file name and line number of the class's associated classdoc'd package
	definition, and a hashref mapping method names to an arrayref of source file name and
	linenumber.

=end classdoc

=cut

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;
}

=pod

=begin classdoc

Generate fully qualified pathname of output classdoc
file for a given package name. Also creates the path
if needed.

@param $class	package name to be resolved to output classdoc file

@return	the fully qualified pathname to the classdocs for $class,
	with a '.html' qualifier.

=end classdoc

=cut

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) =
		(
		"CONSTR",
		"CONSTR",
		"METHOD",
		"METHOD"
		);

	my $doc = "


$class


 




909




 





 





 





 





 





 



  




910




 





 





 





 





 





 



  




911




 





 





 





 





 





 



  SUMMARY: $constrsum | $methsum 




912




 





 





 





 





 





 



   




913




 





 





 





 





 





 



  




914




 





 





 





 





 





 



 DETAIL: $constrdet | $methdet 




915




 





 





 





 





 





 



  




916




 





 





 





 





 





 



  




917


 SUMMARY: $constrsum | $methsum


DETAIL: $constrdet | $methdet



Class $class
";
#
#	process InheritsFrom
#
	my $base;
	my @bases = ();
	foreach (keys %{$info->{InheritsFrom}}) {
		$base = $_;
		$base=~s/::/\//g;
#		$base=~s/^$dir\///;	# remove matching headers
		push @bases, "$_";
	}

	$doc .=  "


Inherits from:
" . join("\n", @bases) . "


"
		if scalar @bases;
#
#	process SubclassedBy
#
	@bases = ();
	foreach (keys %{$info->{SubclassedBy}}) {
		$base = $_;
		$base=~s/::/\//g;
#		$base=~s/^$dir\///;	# remove matching headers
		push @bases, "$_";
	}

	$doc .=  "


Known Subclasses:
" . join("\n", @bases) . "


"
		if scalar @bases;
#
#	process package tags
#
	$doc .=  '

';
	$doc .=  "Deprecated." .
		(($info->{deprecated} ne '1') ? " $info->{deprecated}\n" : "\n") .
		"\n"
		if $info->{deprecated};

	$doc .=  "
$info->{Description}

"
		if $info->{Description};

	$doc .=  '

';
	$doc .=  "
Author:
	$info->{author}
"
		if $info->{author};

	$doc .=  "
Version:
	$info->{Version}
"
		if $info->{Version};

	$doc .=  "
Since:
	$info->{since}
"
		if $info->{since};

	$doc .=  join('', "
See Also:
	", _makeSeeLinks($info->{see}, $pathpfx), "
")
		if $info->{see};

	$doc .=  "

Class instances are $info->{instance} references.
"
		if $info->{instance};

	$doc .=  "

Unless otherwise noted, $info->{self} is the object instance variable.
"
		if $info->{self};

#
#	process imports
#
	$doc .=  join('', "

 




1023




 





 





 





 





 





 



 Imported Symbols 




1024




 





 





 





 





 





 



 ", _makeExportDesc($info->{imports}, '_i_'), " 




1025

", _makeExportDesc($info->{imports}, '_i_'), "


")
		if $info->{imports};
#
#	process exports
#
	$doc .=  join('', "

 




1035




 





 





 





 





 





 



 Exported Symbols 




1036




 





 





 





 





 





 



 ", _makeExportDesc($info->{exports}, '_e_'), " 




1037

", _makeExportDesc($info->{exports}, '_e_'), "


")
		if $info->{exports};
#
#	process members
#
	$doc .=  join('', "

 




1047




 





 





 





 





 





 



 Public Instance Members 




1048




 





 





 





 





 





 



 ", _makeExportDesc($info->{member}, '_m_'), " 




1049

", _makeExportDesc($info->{member}, '_m_'), "


")
		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 .=  "

";

	my %constructors = ();
	my $constructor;
	my $anchored;
	foreach (sort keys %{$info->{Methods}}) {
		next
			unless exists $info->{Methods}{$_}{constructor};
		$anchored = 1,
		$doc .= "

",
			unless $anchored;

		$doc .=  "
\n";  




1084




 





 





 





 





 





 



 Constructor Summary 




1085




 





 





 





 





 





 



 " 




1086




 





 





 





 





 





 



 			unless $constructor; 




1087




 





 





 





 





 





 



   




1088




0





 





 





 





 





0



 		$constructor = $constructors{$_} = delete $info->{Methods}{$_}; 




1089




 





 





 





 





 





 



   




1090




0





 





 





 





 





0



 		$doc .=  join('', " 




1091




 





 





 





 





 





 



  




1092




 





 





 





 





 





 



 $_", _makeParamList($constructor->{param}), " 




1093




 





 





 





 





 





 



 "); 




1094




0




  
  0
  




 





 





 





0



 		if ($constructor->{deprecated}) { 




 




 




  
  0
  




 





 





 





 



   




1095




0




  
  0
  




 





 





 





0



 			$doc .=  ' 




1096




 





 





 





 





 





 



  




1097




 





 





 





 





 





 



           Deprecated. ' . 




1098




 





 





 





 





 





 



 				(($constructor->{deprecated} ne '1') ? "$constructor->{deprecated}" : ''); 




1099




 





 





 





 





 





 



 		} 




1100




 





 





 





 





 





 



 		elsif ($constructor->{Description}) { 




1101




0





 





 





 





 





0



 			my $descr =  $constructor->{Description}; 




1102




0




  
  0
  




 





 





 





0



 			my $brief = _briefDescription(($descr=~/^\s*Constructor\.\s*(.*)$/s) ? $1 : $descr); 




1103




0





 





 





 





 





0



 			$doc .=  " 




1104




 





 





 





 





 





 



  




1105




 





 





 





 





 





 



           $brief 




1106




 





 





 





 





 





 



 "; 




1107




 





 





 





 





 





 



 		} 




1108




0





 





 





 





 





0



 		$doc .=  "




1109




 





 





 





 





 





 



 	} # end for constructors 




1110




8





 





 





 





 





39



 	$info->{constructors} = \%constructors; 




1111




8




  
 50
  




 





 





 





22



 	if ($constructor) { 




1112




0





 





 





 





 





0



 		$doc .=  "\n"

"
			unless $constructor;

		$constructor = $constructors{$_} = delete $info->{Methods}{$_};

		$doc .=  join('', "

$_", _makeParamList($constructor->{param}), "
");
		if ($constructor->{deprecated}) {
			$doc .=  '

          Deprecated. ' .
				(($constructor->{deprecated} ne '1') ? "$constructor->{deprecated}" : '');
		}
		elsif ($constructor->{Description}) {
			my $descr =  $constructor->{Description};
			my $brief = _briefDescription(($descr=~/^\s*Constructor\.\s*(.*)$/s) ? $1 : $descr);
			$doc .=  "

          $brief
";
		}
		$doc .=  "
	} # end for constructors
	$info->{constructors} = \%constructors;
	if ($constructor) {
		$doc .=  "
	}
	else {
		$doc=~s!CONSTR!CONSTR!;
		$doc=~s!CONSTR!CONSTR!;
	}
#
#	process methods
#
	my @methods = sort keys %methodmap;
	my $methcount = @methods;
	if ($methcount) {
		$doc .=  "

\n";  




1127




 





 





 





 





 





 



 Method Summary 




1128




 





 





 





 





 





 



 "; 




1129




8





 





 





 





 





20



 		foreach (@methods) { 




1130




198





 





 





 





 





351



 			my $method = $info->{Methods}{$_}; 




1131




198





 





 





 





 





576



 			$doc .=  join('', " 




1132




 





 





 





 





 





 



  




1133




 





 





 





 





 





 



 $_", _makeParamList($method->{param}), " 




1134




 





 





 





 





 





 



 "); 




1135




198




  
100
  




 





 





 





717



 			if ($method->{deprecated}) { 




 




 




  
100
  




 





 





 





 



   




1136




2




  
 50
  




 





 





 





11



 				$doc .=  ' 




1137




 





 





 





 





 





 



  




1138




 





 





 





 





 





 



           Deprecated. ' . 




1139




 





 





 





 





 





 



 				(($method->{deprecated} ne '1') ? "$method->{deprecated}" : ''); 




1140




 





 





 





 





 





 



 			} 




1141




 





 





 





 





 





 



 			elsif ($method->{Description}) { 




1142




192




  
100
  




 





 





 





638



 				my $descr = ($method->{static} ? "(class method) " : '') . $method->{Description}; 




1143




192





 





 





 





 





333



 				my $brief = _briefDescription($descr); 




1144




192





 





 





 





 





622



 				$doc .=  " 




1145




 





 





 





 





 





 



  




1146




 





 





 





 





 





 



           $brief 




1147




 





 





 





 





 





 



 "; 




1148




 





 





 





 





 





 



 			} 




1149




198





 





 





 





 





336



 			$doc .=  "




1150




 





 





 





 





 





 



 		} 




1151




8





 





 





 





 





15



 		$doc .=  "

";
		foreach (@methods) {
			my $method = $info->{Methods}{$_};
			$doc .=  join('', "

$_", _makeParamList($method->{param}), "
");
			if ($method->{deprecated}) {
				$doc .=  '

          Deprecated. ' .
				(($method->{deprecated} ne '1') ? "$method->{deprecated}" : '');
			}
			elsif ($method->{Description}) {
				my $descr = ($method->{static} ? "(class method) " : '') . $method->{Description};
				my $brief = _briefDescription($descr);
				$doc .=  "

          $brief
";
			}
			$doc .=  "
		}
		$doc .=  "

";
	}
	else {
		$doc=~s!METHOD!METHOD!;
		$doc=~s!METHOD!METHOD!;
	}

	if (keys %constructors) {
		$doc .=  "

 




1164




 





 





 





 





 





 



  




1165




 





 





 





 





 





 



 	Constructor Details 




1166




 





 





 





 





 





 



  




1167




";
		foreach (sort keys %constructors) {
			my $method = $constructors{$_};
			my $returns = $method->{return};
			my $descr =  $method->{Description} || ' ';
			$descr=~s/^\s*Constructor\.\s*//;
			$doc .=  join('', "

$_

$_", _makeParamList($method->{param}), "


$descr


");
			$doc .=  join('', "Parameters:\n", _makeParamDesc($method->{param}))
				if $method->{param};

			$doc .=  "Returns:$returns\n"
				if $returns;

			$doc .=  "Since:$method->{since}\n"
				if $method->{since};

			$doc .=  join('', "See Also:", _makeSeeLinks($method->{see}, $pathpfx), "\n")
				if $method->{see};

			$doc .=  "\n";
		}
		$doc .=  "\n\n";
	} # end if constructor

	if ($methcount) {
		$doc .=  "

 




1206




 





 





 





 





 





 



  




1207




 





 





 





 





 





 



 	Method Details 




1208



";
		foreach (@methods) {
			my $method = $info->{Methods}{$_};
			my $returns = $method->{return};
			my $returnlist = $method->{returnlist};
			my $descr =  ($method->{static} ? "(class method) " : '') .
				($method->{Description} || ' ');
			$doc .=  join('', "

$_

$_", _makeParamList($method->{param}), "


$descr


");

			if ($method->{simplex}) {
				$doc .=  ($method->{urgent} ?
					"Simplex, Urgent\n" :
					"Simplex\n");
			}
			elsif ($method->{urgent}) {
				$doc .=  "Urgent\n";
			}

			$doc .=  join('', "Parameters:\n", _makeParamDesc($method->{param}))
				if $method->{param};

			if ($returns) {
				$doc .=  ($returnlist ?
					"In scalar context, returns:$returns\n" :
					"Returns:$returns\n");
			}

			$doc .=  ($returns ?
				"In list context, returns:($returnlist)\n" :
				"Returns:($returnlist)\n")
				if $returnlist;

			$doc .=  "Since:$method->{since}\n"
				if $method->{since};

			$doc .=  join('', "See Also:", _makeSeeLinks($method->{see}, $pathpfx), "\n")
				if $method->{see};

			$doc .=  "\n";
		}	# end foreach method
	} # end if methods
#
#	finish up
#
	my $tstamp = scalar localtime();

	$doc .=  "


Generated by POD::ClassDoc $VERSION on $tstamp




";
	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 , , , and  tags
#	NOTE: need a nesting level to construct updir prefixes
#
	my ($updir, $path) = _pathFromClass($class);
	my @parts = ();
	my $method;
	$updir ||= '';
	$info->{Description}=~s!([^<]+)!$1!g;
	$info->{Description}=~s!<(export|import|method|member)>(\w+)!$2!g;
	$info->{Description}=~s!<(export|import|method|member|package)>([\w\:]+)!
		{ @parts = split('\:\:', $2); $method = ($1 eq 'package') ? '' : pop @parts;
			"$2" }!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 = '(optional)' . $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 = '(optional)' . $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 => value, "
		while ($i < $#$params);

	chop $p,
	chop $p
		if (length($p) > 1);

	return "$p)";
}

sub _makeParamDesc {
	my $params = shift;
	my $p = ''; \n" 




1378




144





 





 





 





 





147



 	my ($t, $d, $sep); 




1379




144





 





 





 





 





175



 	my $i = 0; 




1380




 





 





 





 





 





 



   




1381




144




  
100
  




 





 





 





2278



 	$t = $params->[$i++], 




1382




 





 





 





 





 





 



 	$d = $params->[$i++], 




1383




 





 





 





 





 





 



 	$sep = ($t=~/^[\\]?[\$\%\@\*\&]/) ? ' - ' : ' => ', 




1384




 





 





 





 





 





 



 	$p .= "$t$sep$d




1385




 





 





 





 





 





 



 		while ($i < $#$params); 




1386




 





 





 





 





 





 



   




1387




144





 





 





 





 





698



 	return $p . "\n";
	my ($t, $d, $sep);
	my $i = 0;

	$t = $params->[$i++],
	$d = $params->[$i++],
	$sep = ($t=~/^[\\]?[\$\%\@\*\&]/) ? ' - ' : ' => ',
	$p .= "
		while ($i < $#$params);

	return $p . "
}

sub _makeExportDesc {
	my ($params, $pfx) = @_;
	my $p = '';

	my %t = @$params;
	return join("\n",
		map "
}

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("\n", @{$_[0]}) . "\n";
}

sub _briefDescription {
	my $descr = shift;
	while ($descr=~/\G.*?((?:]*>[^<]*<\/a>)|\.|\?|\!)/igcs) {
		return substr($descr, 0, $+[1]) if ($1 eq '.') || ($1 eq '?') || ($1 eq '!');
	}
	return $descr;
}

1;