|
|
Folded lines 1 to 27
package PPI::HTML::CodeFolder;
Folded lines 29 to 35
our $VERSION = '1.01';
our %classabvs = qw(
arrayindex ai
backtick bt
cast cs
comment ct
core co
data dt
double db
end en
heredoc hd
heredoc_content hc
heredoc_terminator ht
interpolate ip
keyword kw
label lb
line_number ln
literal ll
magic mg
match mt
number nm
operator op
pod pd
pragma pg
prototype pt
readline rl
regex re
regexp re
separator sp
single sg
structure st
substitute su
symbol sy
transliterate tl
word wo
words wd
);
#
# fold section regular expressions
#
my %foldres = (
Comments => [
qr/\G(?<=<pre>)\s*(<span\s+class=['"]comment['"]>.+?<\/span>)(?=<br>)/,
qr/\G.*?<br>\s*(<span\s+class=['"]comment['"]>.+?<\/span>)(?=<br>)/
],
POD => [
qr/\G(?<=<pre>)\s*(<span\s+class=['"]pod['"]>.+?<\/span>)(?=<br>)/,
qr/\G.*?<br>\s*(<span\s+class=['"]pod['"]>.+?<\/span>)(?=<br>)/
],
Heredocs => [
qr/\G(?<=<pre>)\s*(<span\s+class=['"]heredoc_content['"]>.+?<\/span>)(?=<br>)/,
qr/\G.*?<br>\s*(<span\s+class=['"]heredoc_content['"]>.+?<\/span>)(?=<br>)/
],
Imports => [
qr/\G(?<=<pre>)\s*
(
(?:<span\s+class=['"]keyword['"]>(?:use|require)<\/span>.+?;\s*)+
(?:<span\s+class=['"]comment['"]>.+?<\/span>)?
)
(?=<br>)
/x,
qr/\G.*?<br>\s*
(
(?:<span\s+class=['"]keyword['"]>(?:use|require)<\/span>.+?;\s*)+
(?:<span\s+class=['"]comment['"]>.+?<\/span>)?
)
(?=<br>)
/x
],
);
Folded lines 109 to 112
our $ftcss = <<'EOFTCSS';
Folded lines 114 to 169
EOFTCSS
#
# fold expansion javascript
#
our $ftjs = <<'EOFTJS';
Folded lines 175 to 440
EOFTJS
Folded lines 442 to 484
sub new {
my ($class, %args) = @_;
my $fold = delete $args{fold};
my $verb = delete $args{verbose};
Folded lines 490 to 493
my $needs_ln = delete $args{line_numbers};
#
# force page wrapping
#
$args{page} = 1;
my $self = $class->SUPER::new(%args);
return undef
unless $self;
$self->{_needs_ln} = $needs_ln;
$self->{_verbose} = $verb;
$self->{fold} = $fold ?
{ %$fold } :
{
Abbreviate => \%classabvs,
Comments => 1,
Heredocs => 0,
Imports => 0,
Javascript => undef,
Expandable => 0,
MinFoldLines => 4,
POD => 1,
Stylesheet => undef,
Tabs => 4,
};
$self->{fold}{Abbreviate} = \%classabvs
if $self->{fold}{Abbreviate} && (! (ref $self->{fold}{Abbreviate}));
$self->{fold}{MinFoldLines} = 4
unless $self->{fold}{MinFoldLines};
$self->{fold}{Tabs} = 4
unless $self->{fold}{Tabs};
#
# keep a running package/method cross reference
#
$self->{_pkgs} = {};
return $self;
}
Folded lines 535 to 548
sub fold_javascript { return $ftjs; }
Folded lines 550 to 563
sub fold_css {
my $self = shift;
my $orig_colors = exists $self->{colors};
my $css = $self->_css_html() || << 'EOCSS';
Folded lines 568 to 573
EOCSS
my $ftc = $ftcss;
if ($self->{colors}{line_number}) {
my $lnc = $self->{colors}{line_number};
$ftc=~s/(.lnpre\s+.+?color: )#888888;/$1$lnc;/gs;
}
delete $self->{colors} unless $orig_colors;
$css=~s|-->\s*</style>||s;
Folded lines 584 to 587
$css=~s/(<!--.*?\n)/$1\n\n.dummy_class_for_firefox { color: white; }\n/;
#
# replace classes w/ abbreviations
#
if ($self->{fold}{Abbreviate}) {
my ($long, $abv);
$css=~s/\.$long \{/.$abv {/s
while (($long, $abv) = each %{$self->{fold}{Abbreviate}});
}
return $css . $ftc;
}
Folded lines 599 to 622
sub html {
my ($self, $src, $outfile) = @_;
my $orig_colors = exists $self->{colors};
my $html = $self->SUPER::html($src)
or return undef;
$outfile = (ref $src) ? '' : "$src.html"
unless $outfile;
Folded lines 632 to 635
my @lns = split /\n/, $html;
my $tabsz = $self->{fold}{Tabs};
foreach my $line (@lns) {
next if $line=~s/^\s*$//;
next unless $line=~tr/\t//;
my $offs = 0;
my $pad;
Folded lines 643 to 646
pos($line) = 0;
while ($line=~/\G.*?((<[^>]+>)|\t)/gc) {
$offs += length($2),
next
unless ($1 eq "\t");
$pad = $tabsz - ($-[1] - $offs) % $tabsz;
substr($line, $-[1], 1, ' ' x $pad);
pos($line) = $-[1] + $pad - 1;
}
}
$html = join("\n", @lns);
delete $self->{colors} unless $orig_colors;
my $opts = $self->{fold};
#
# extract stylesheet and replace with abbreviated version
#
my $style = $opts->{Stylesheet} ?
"<link type='text/css' rel='stylesheet' href='$opts->{Stylesheet}' />" :
$self->fold_css();
$style .= $opts->{Javascript} ?
"\n<script type='text/javascript' src='$opts->{Javascript}'></script>\n" :
"\n<script type='text/javascript'>\n$ftjs\n</script>\n"
if $opts->{Expandable};
#
# original html may have no style, so we've got to add OR replace
#
$html=~s|</head>|$style</head>|s
unless ($html=~s|<style type="text/css">.+</style>|$style|s);
#
# force spans to end before line endings
#
$html=~s!(<br>\s*)</span>!</span>$1!g;
Folded lines 683 to 687
$html=~s/(?!<br>\s+)(<span class=['"]comment['"]>[^<]+)<br>\n/$1<\/span><br>\n<span class="comment">/g;
Folded lines 689 to 693
my %folddivs = ( 1 => [ 0, '', 0, 0 ]);
Folded lines 695 to 699
my $lineno = 1;
my $lastfold = 1;
$html=~s/<br>\n/<br>/g;
#
# now process remainder
#
study $html;
pos($html) = 0;
$html=~/^.*?(<body[^>]+><pre>)/s;
my $startpos = $+[1];
#
# map linebreak positions to line numbers
#
my @lnmap = (0, $startpos);
push @lnmap, $+[1]
while ($html=~/\G.*?(<br>)/gcs);
#
# now scan for foldables
#
pos($html) = $startpos;
my @folds = _extractFolds(\$html, $startpos, \@lnmap, $opts);
Folded lines 722 to 726
my $ln = 0;
my @ftsorted = ();
foreach (@folds) {
if ($_->[1] - $_->[0] + 1 >= $opts->{MinFoldLines}) {
$folddivs{$_->[0]} = [ $_->[1], substr($html, $lnmap[$_->[0]], $lnmap[$_->[1] + 1] - $lnmap[$_->[0]]),
$lnmap[$_->[0]], $lnmap[$_->[1] + 1] ];
push @ftsorted, $_->[0];
}
elsif ($self->{_verbose}) {
print "*** skipping section at line $_->[0]to $_->[1]\n";
print substr($html, $lnmap[$_->[0]], $lnmap[$_->[1] + 1] - $lnmap[$_->[0]]), "\n";
}
}
Folded lines 740 to 745
substr($html, $folddivs{$_}[2], $folddivs{$_}[3] - $folddivs{$_}[2],
"<span id='src$_' class='foldfill'>Folded lines $_ to " . $folddivs{$_}[0] . "</span>\n")
foreach (reverse @ftsorted);
#
# abbreviate the default span classes for both the html and fold divs
#
pos($html) = 0;
my $abvs = $opts->{Abbreviate};
if ($abvs) {
$html=~s/(<span\s+class=['"])([^'"]+)(['"])/$1 . ($$abvs{$2} || $2) . $3/egs;
if ($opts->{Expandable}) {
$_->[1]=~s/(<span\s+class=['"])([^'"]+)(['"])/$1 . ($$abvs{$2} || $2) . $3/egs
foreach (values %folddivs);
}
}
#
# create and insert fold DIVs if requested
#
my $expdivs = $opts->{Expandable} ? _addFoldDivs(\%folddivs, \@ftsorted) : '';
$html=~s/<br>/\n/gs;
Folded lines 767 to 771
_addLineNumTable(\$html, \@ftsorted, \%folddivs, \$expdivs, $#lnmap)
if $self->{_needs_ln};
#
# extract a package/method reference list, and add anchors for them
#
$self->_extractXRef(\$html, $outfile);
#
# report number of spans, for firefox performance report
#
if ($self->{_verbose}) {
my $spancnt = $html=~s/<\/span>/<\/span>/gs;
print "\n***Total spans: $spancnt\n";
}
Folded lines 785 to 788
$html=~s!\n\n!\n \n!gs;
return $html;
}
Folded lines 793 to 805
sub getCrossReference { return $_[0]->{_pkgs}; }
Folded lines 807 to 825
sub writeTOC {
my $self = shift;
my $path = shift;
$@ = "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 837 to 852
sub getTOC {
my $self = shift;
my %args = @_;
my @order = $args{Order} ? @{$args{Order}} : ();
my $sources = $self->{_pkgs};
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 %$sources) {
push @order, $_ unless exists $ordered{$_};
}
foreach my $class (@order) {
#
# due to input @order, we might get classes that don't exist
#
next unless exists $sources->{$class};
$base = $sources->{$class}{URL};
$doc .= "<li><a href='$base' target='mainframe'>$class</a>
<ul>\n";
my $info = $sources->{$class}{Methods};
$doc .= "<li><a href='$info->{$_}' target='mainframe'>$_</a></li>\n"
foreach (sort keys %$info);
$doc .= "</ul>\n</li>\n";
}
$doc .= "
</ul>
<!-- INDEX END -->
</small>
</body>
</html>
";
return $doc;
}
Folded lines 899 to 916
sub writeFrameContainer {
my ($self, $path, $title, $home) = @_;
$@ = "Can't open $path/index.html: $!",
return undef
unless open(OUTF, ">$path/index.html");
print OUTF $self->getFrameContainer($title, $home);
close OUTF;
return $self;
}
Folded lines 927 to 937
sub getFrameContainer {
my ($self, $title, $home) = @_;
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>
";
}
#
# extract a package/method reference list, and add anchors for them
#
sub _extractXRef {
my ($self, $html, $outfile) = @_;
$self->{_pkgs} = {} unless exists $self->{_pkgs};
my $pkgs = $self->{_pkgs};
my $curpkg = 'main';
my $pkglink;
while ($$html=~/\G.*?(<span class=['"]kw['"]>)\s*(package|sub)\s*<\/span>\s*(<span class=['"][^'"]+['"]>\s*)?([\w:]+)/gcs) {
# " to keep Textpad formatting happy
my $pkg = $4;
my $next = pos($$html);
my $insert = $-[1];
if ($2 eq 'package') {
$curpkg = $pkg;
next if exists $pkgs->{$pkg} && $pkgs->{$pkg}{URL}; # only use 1st definition of package
$pkglink = $pkg;
$pkgs->{$pkg} = {
URL => "$outfile#$pkg",
Methods => {}
};
}
else {
if ($pkg=~/^(.+)::(\w+)$/) {
#
# fully qualified name, check if we have a pkg entry for it
#
$pkgs->{$1} = {
URL => '',
Methods => {}
}
unless exists $pkgs->{$1};
$pkgs->{$1}{Methods}{$2} = "$outfile#$pkg";
$pkglink = $pkg;
}
else {
$pkglink = "$curpkg\:\:$pkg";
$pkgs->{$curpkg}{Methods}{$pkg} = "$outfile#$pkglink";
}
}
$pkglink = "<a name='$pkglink'></a>";
substr($$html, $insert, 0, $pkglink);
$next += length($pkglink);
pos($$html) = $next;
}
return $html;
}
sub _extractFolds {
my ($html, $startpos, $lnmap, $opts) = @_;
Folded lines 1008 to 1011
pos($$html) = $startpos;
my %folded = (
Whitespace => [],
Comments => [],
POD => [],
Heredocs => [],
Imports => [],
);
my $whitespace = [];
#
# accumulate foldable sections, including leading/trailing whitespace
#
push @{$folded{Whitespace}}, [ $-[1], $+[1] - 1 ]
while ($$html=~/\G.*?<br>((?:\s*<br>)+)/gcs);
_mergeSection(_cvtToLines($folded{Whitespace}, $lnmap));
pos($$html) = $startpos;
foreach (qw(Comments POD Heredocs Imports)) {
next unless $opts->{$_};
#
# capture anything at the very beginning
#
my $fre = $foldres{$_}[0];
push @{$folded{$_}}, [ $-[1], $+[1] - 1 ]
if ($$html=~/$fre/gcs);
$fre = $foldres{$_}[1];
push @{$folded{$_}}, [ $-[1], $+[1] - 1 ]
while ($$html=~/$fre/gcs);
_mergeSection(_cvtToLines($folded{$_}, $lnmap));
pos($$html) = $startpos;
}
#
# now merge different sections
#
my $last = 'Whitespace';
foreach (qw(Imports POD Heredocs Comments)) {
_mergeSections($folded{$_}, $folded{$last});
$last = $_;
}
return @{$folded{$last}};
}
sub _cvtToLines {
my ($pos, $lnmap) = @_;
my $ln = 1;
foreach (@$pos) {
$ln++ while ($ln <= $#$lnmap) && ($lnmap->[$ln] <= $_->[0]);
$_->[0] = $ln - 1;
$ln++ while ($ln <= $#$lnmap) && ($lnmap->[$ln] <= $_->[1]);
$_->[1] = $ln - 1;
}
return $pos;
}
sub _mergeSection {
my $sect = shift;
my @temp = shift @$sect;
foreach (@$sect) {
push(@temp, $_),
next
unless ($temp[-1][1] + 1 >= $_->[0]);
#
# if current surrounds new, the discard new
#
$temp[-1][1] = $_->[1]
if ($temp[-1][1] < $_->[1]);
}
@$sect = @temp;
1;
}
sub _mergeSections {
my ($first, $second) = @_;
@$first = @$second,
return $first
if ($#$first < 0);
my @temp = ();
push @temp, (($first->[0][0] < $second->[0][0]) ? shift @$first : shift @$second)
while (@$first && @$second);
push @temp, @$first if scalar @$first;
push @temp, @$second if scalar @$second;
_mergeSection(\@temp);
@$first = @temp;
1;
}
sub _addLineNumTable {
my ($html, $ftsorted, $folddivs, $expdivs, $linecnt) = @_;
$$html=~s/<pre>/<pre class='bodypre'>/;
$$html=~/(<body[^>]+>)/s;
my $insert = $+[0];
#
# generate JS declaration of fold sections
#
my $startfolds = scalar @$ftsorted ?
'[' . join(',', @$ftsorted) . " ],\n[" . join(',', map $folddivs->{$_}[0], @$ftsorted) . " ]" :
"[], []";
my $linenos = $$expdivs . "
<table border=0 width='100\%' cellpadding=0 cellspacing=0>
<tr>
<td width=40 bgcolor='#E9E9E9' align=right valign=top>
<pre id='lnnomargin' class='lnpre'>
</pre>
</td>
<td width=8 bgcolor='#E9E9E9' align=right valign=top>
<pre id='btnmargin' class='lnpre'>
</pre>
</td>
<td bgcolor='white' align=left valign=top>
";
substr($$html, $insert, 0, $linenos);
substr($$html, index($$html, '</body>'), 0, "
</td></tr></table>
<script type='text/javascript'>
<!--
var ppihtml = new ppiHtmlCF($startfolds);
ppihtml.renderMargins($linecnt);
/*
* all rendered, now selectively open from any existing cookie
*/
ppihtml.openFromCookie();
-->
</script>
"
);
return 1;
}
sub _addFoldDivs {
my ($folddivs, $ftsorted) = @_;
foreach my $ft (values %$folddivs) {
$ft->[1]=~s/<br>/\n/gs;
#
# squeeze out leading whitespace, but keep aligned
#
my $shortws = 1000000;
my @lns = split /\n/, $ft->[1];
#
# expand tabs as needed (we use 4 space tabs)
#
foreach (@lns) {
next if s/^\s*$//;
$shortws = 0, last
unless /^(\s+)/;
$shortws = length($1)
if ($shortws > length($1))
}
$ft->[1] = join("\n", map { $_ ? substr($_, $shortws) : ''; } @lns)
if $shortws;
#
# move whitespace inside any leading/trailing spans
#
$ft->[1]=~s!(</span>)(\s+)$!$2$1!s;
$ft->[1]=~s!^(\s+)(<span [^>]+>)!$2$1!s;
#
# if ends on span, make sure its not creating newline
#
$ft->[1]=~s!\n</span>$! </span>!s;
#
# likewise if it doesn't end on a span
#
$ft->[1]=~s!\n$!!s;
}
return join('', map "\n<div id='ft$_' class='folddiv'><pre id='preft$_'>$folddivs->{$_}[1]</pre></div>", @$ftsorted);
}
1;
|