package HTML::Revelation;
use strict;
use warnings;
our @accessors = (qw/caption class2depth class_name comment css_output_file css_url empty html_output_file input_file/);
use accessors::classic qw/caption class2depth class_name comment css_output_file css_url empty html_output_file input_file/;
use File::Spec;
use HTML::Entities::Interpolate;
use HTML::Tagset;
use HTML::TreeBuilder;
use List::Cycle;
our @ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
# This allows declaration use HTML::Revelation ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
);
our $VERSION = '1.03';
# -----------------------------------------------
sub add_caption
{
my($self, $output) = @_;
my(@comment);
push @comment, qq|
|;
push @comment, qq|
|;
if ($self -> comment() )
{
push @comment, '
Comment:
' . $self -> comment() . '
';
}
push @comment, '
Input file:
' . $self -> input_file() . '
';
push @comment, '
HTML output file:
' . $self -> html_output_file() . '
';
push @comment, '
CSS output file:
' . $self -> css_output_file() . '
';
push @comment, '
Creator:
' . __PACKAGE__ . " V $VERSION
";
push @comment, '
';
push @comment, '
';
push @comment, qq||;
push @$output, @comment;
} # End of add_caption.
# -----------------------------------------------
sub build_css_file
{
my($self) = @_;
my(@color) = split(/\n/, $self -> load_colors() );
# Discard dark colors.
shift @color for 1 .. 220;
my($cycle) = List::Cycle -> new({values => \@color});
my($class) = 'c0000';
my($class_name) = $self -> class_name();
my($depth) = $self -> class2depth();
my($output) = [];
my($color);
my($padding);
while ($class lt $class_name)
{
$class++;
$color = $cycle -> next();
$padding = 4 * $$depth{$class};
push @$output, < empty()}{$tag_name} || 0;
} # End of empty_tag.
# -----------------------------------------------
sub format_attributes
{
my($self, $node) = @_;
my(%attr) = $node -> all_attr();
my(@s);
push @s, map{qq|$_ = "$attr{$_}"|} grep{! /^_/} sort keys %attr;
my($s) = join(', ', @s) || '';
$s = " $s" if ($s);
return $s;
} # End of format_attributes.
# -----------------------------------------------
sub load_colors
{
my($self) = @_;
return < caption(0);
$self -> class2depth({});
$self -> class_name('c0000');
$self -> comment('');
$self -> css_output_file('');
$self -> css_url('');
$self -> empty
({
area => 1,
base => 1,
basefont => 1,
br => 1,
col => 1,
embed => 1,
frame => 1,
hr => 1,
img => 1,
input => 1,
isindex => 1,
link => 1,
meta => 1,
param => 1,
wbr => 1,
});
$self -> html_output_file('');
$self -> input_file('');
# Process user options.
my($attr_name);
for $attr_name (@accessors)
{
if (exists($arg{$attr_name}) )
{
$self -> $attr_name($arg{$attr_name});
}
}
if (! $self -> css_output_file() )
{
die 'CSS output file not specifed';
}
if (! $self -> css_url() )
{
die 'CSS URL not specifed';
}
if (! $self -> html_output_file() )
{
die 'HTML output file not specifed';
}
if (! -f $self -> input_file() )
{
die 'Cannot find input file: ' . $self -> input_file();
}
$$self{'_empty'} =
{
area => 1,
base => 1,
basefont => 1,
br => 1,
col => 1,
embed => 1,
frame => 1,
hr => 1,
img => 1,
input => 1,
isindex => 1,
link => 1,
meta => 1,
param => 1,
wbr => 1,
};
return $self;
} # End of new.
# -----------------------------------------------
sub process
{
my($self, $css_url, $depth, $node, $output) = @_;
$depth++;
# If ref $node is true, this node has children, so we're going to recurse.
if (ref $node)
{
my($tag) = lc $node -> tag();
my($empty_tag) = $self -> empty_tag($tag);
my($content);
# If the tag can appear in the body, apply makeup aka markup.
if ($HTML::Tagset::isBodyElement{$tag})
{
# Fabricate a CSS class name for this node,
# and stash it away for when we generate the CSS file.
my($class_name) = $self -> class_name();
$class_name++;
$self -> class_name($class_name);
my($hash_ref) = $self -> class2depth();
$$hash_ref{$class_name} = $depth;
$self -> class2depth($hash_ref);
# Start a div for this node.
my($s) = $self -> format_attributes($node);
if ($empty_tag)
{
$s .= ' /';
}
push @$output, qq|
$Entitize{"<$tag$s>"}|;
# Process this node's children.
for $content ($node -> content_list() )
{
$self -> process($css_url, $depth, $content, $output);
}
$s = '
';
if (! $empty_tag)
{
$s = qq|$Entitize{""}$s|;
}
push @$output, $s;
}
else
{
# It's the head-type tag, so just output it. This includes the real body tag.
push @$output, "<$tag" . ($empty_tag ? ' /' : '') . '>';
# Add commentry, if desired, just after we output the real body tag.
if ($tag eq 'body')
{
if ($self -> caption() )
{
$self -> add_caption($output);
}
# Output a fake (i.e. visible) body tag.
my($s) = $self -> format_attributes($node);
push @$output, $Entitize{""};
}
# Process this node's children.
for $content ($node -> content_list() )
{
$self -> process($css_url, $depth, $content, $output);
}
# Output the CSS link just before we output .
if ($tag eq 'head')
{
push @$output, qq||;
}
if (! $empty_tag)
{
push @$output, "";
}
}
}
# else
# {
# # This would include the input text in the output.
#
# push @$output, $node;
# }
} # End of process.
# -----------------------------------------------
sub run
{
my($self) = @_;
my($root) = HTML::TreeBuilder -> new();
my($input_file) = $self -> input_file();
my($result) = $root -> parse_file($input_file) || die "Can't parse: $input_file";
my($depth) = 0;
my($output) = [];
# Build the HTML output.
$self -> process($self -> css_url(), $depth, $root, $output);
$root -> delete();
push @$output, $Entitize{'
'};
# Write the HMTL file.
my($html_output_file) = $self -> html_output_file();
open(OUT, "> $html_output_file") || die "Can't open(> $html_output_file): $!";
print OUT join("\n", @$output), "\n";
close OUT;
# Write the CSS file.
$output = $self -> build_css_file();
my($css_output_file) = $self -> css_output_file();
open(OUT, "> $css_output_file") || die "Can't open(> $css_output_file): $!";
print OUT map{"$_\n"} @$output;
close OUT;
} # End of run.
# -----------------------------------------------
1;
=pod
=head1 NAME
HTML::Revelation - Reveal HTML document structure in a myriad of colors
=head1 Synopsis
#!/usr/bin/perl
use strict;
use warnings;
use HTML::Revelation;
# -------------------
my($reveal) = HTML::Revelation -> new
(
caption => 1,
comment => "DBIx::Admin::CreateTable's POD converted to HTML with my pod2html.pl",
css_output_file => 'CreateTable.css',
css_url => '/',
html_output_file => 'CreateTable.html',
input_file => 'misc/CreateTable.html',
);
$reveal -> run();
Sample output:
http://savage.net.au/Perl-modules/html/CreateTable.html
=head1 Description
C