| 
	 | 
 | Folded lines 1 to 28
package Pod::Classdoc;
Folded lines 30 to 38
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_' 
);
Folded lines 78 to 81
my $aqua = '#98B5EB';
Folded lines 83 to 142
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;
}
Folded lines 155 to 173
sub add {
    my ($self, $txt, $file) = @_;
    $txt = join("\n", @$txt)
        if ref $txt;
Folded lines 178 to 181
    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;
}
Folded lines 229 to 244
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);
}
Folded lines 263 to 278
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);
Folded lines 417 to 420
            $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) = @_;
Folded lines 461 to 464
    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;
    }
}
Folded lines 484 to 500
sub path {
    my ($self, $path) = @_;
    
    return $self->{_path} unless $path;
    $path=~s/\/+$// unless ($path eq '/');
    my $old = $self->{_path};
    $self->{_path} = $path;
    return $old;
}
Folded lines 510 to 536
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;
}
Folded lines 584 to 596
sub clear {
    my $self = shift;
 
    $self->{_classes} = {};
    return $self;
}
Folded lines 603 to 621
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;
}
Folded lines 633 to 648
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>
";
 
}
Folded lines 672 to 688
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;
}
Folded lines 700 to 716
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;
}
Folded lines 808 to 832
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;
}
Folded lines 853 to 870
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};
Folded lines 1016 to 1019
    $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 ];
}
Folded lines 1276 to 1279
sub _pathFromClass {
    my $class = shift;
    my @parts = split /\:\:/, $class;
    pop @parts;
    return ( '../' x (scalar @parts), join('/', @parts));
}
 
sub _parseTags {
    my ($self, $class, $info, $validtags) = @_;
Folded lines 1289 to 1292
    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;
 |