#!perl

=head1 NAME

Htmlcln - Sanitizes HTML and related files before publication

=head1 SYNOPSIS

perl htmlcln.pl [-t [html|js|css]] [-DVAR[=value] ...] [-v]
-o I<outfile> I<infile>

=head1 DESCRIPTION

The Htmlcln program preprocesses text files such as HTML, JS, or CSS
files and cleans them up.

=over 8
Comments are removed.

Blank lines are removed.

Sections marked "debug" are removed in the retail build.

=back

=head1 OPTIONS

=over 8

=item B<-t> [html|js|css]

Htmlcln normally tries to guess what kind of file it is processing from
the filename extension.  You can explicitly override the guess with the
B<-t> command line switch.

=item B<-D>VAR[=value] ...

Command line definitions are supported in the same manner as the C compiler.
The only command-line variable we pay attention to is the -DDBG flag, which
indicates that this is a debug build.

=item B<-o> I<outfile>

Specifies the name of the output file.

=item I<srcfile>

Specifies the name of the source file.

=back

=cut

use strict qw(vars refs subs);

##############################################################################
#
#   Element -  A class that parses HTML elements
#
#   Instance variables:
#
#       raw         = the raw text
#       attr        = hash of attributes
#       tag         = name of tag, including slash
#
#       If the value of an attribute hash is undef, it means that the
#       attribute is present but with no value.
#

package Element;

#
#   Constructor:  $elem = new Element("<TABLE BORDER>");
#
sub new {
    my ($class, $raw) = @_;
    my $attr = { };
    my $self = { raw => $raw, attr => $attr };
    my $tag;

    if ($raw =~ s/^<([^\s>]*)//) {
        $self->{tag} = uc $1;
        if ($self->{tag} =~ /^[A-Z]/) {
            $raw =~ s/>$//;
            for (;;) {
                if ($raw =~ s/^\s*([-A-Za-z]+)="([^"]*)"// ||
                    $raw =~ s/^\s*([-A-Za-z]+)='([^']*)'// ||
                    $raw =~ s/^\s*([-A-Za-z]+)=(\S*)//) {
                    $attr->{uc $1} = $2;
                } elsif ($raw =~ s/^\s*([A-Za-z]+)//) {
                    $attr->{uc $1} = undef;
                } else {
                    last;
                }
            }
        }
    } else {
        warn "Can't parse \"$raw\"";
    }

    bless $self, $class;

}

#
#   Element::Tag
#
#   Returns the tag.
#
sub Tag {
    my $self = shift;
    $self->{tag};
}

#
#   Element::Attr
#
#   Returns the value of the attribute.
#
sub Attr {
    my ($self, $attr) = @_;
    $self->{attr}{uc $attr};
}

#
#   Element::Exists
#
#   Returns the presence of the attribute.
#
sub Exists {
    my ($self, $attr) = @_;
    exists $self->{attr}{uc $attr};
}


##############################################################################
#
#   Filter base class
#
#   Basic stuff to save people some hassle.
#
#   Per perl tradition, an object is a ref to an anonymous hash where the
#   state is kept.
#
#   Instance variables:
#
#       sink        = reference to filter sink
#

package Filter;

sub new {
    my($class) = @_;
    bless { }, $class;
}

sub SetSink {
    my ($self, $sink) = @_;
    $self->{sink} = $sink;
}

sub Add {
    my $self = shift;
    $self->{sink}->Add(@_);
}

sub Flush { }

sub Close {
    my $self = shift;
    $self->{sink}->Close(@_);
}

sub SinkAdd {
    my $self = shift;
    $self->{sink}->Add(@_);
}

##############################################################################
#
#   TokenFilter filter package
#
#   Does not modify the stream, but merely chops them into tokens, as
#   recognized by NextToken and processed by EachToken.
#
#   Instance data:
#
#       buf         = unprocessed text
#
package TokenFilter;
@TokenFilter::ISA = qw(Filter);

#
#   Append the incoming text to the buffer, then suck out entire tokens.
#
sub Add {
    my($self, $text) = @_;
    my $tok;

    $self->{buf} .= $text;

    while ($self->{buf} ne '' && defined($tok = $self->NextToken))
    {
        $self->EachToken($tok);
    }
}

sub Flush {
    my $self = shift;
    $self->EachToken($self->{buf});
}

#
#   By default, we just sink tokens to the next layer.
#
sub EachToken {
    my($self, $tok) = @_;
    $self->SinkAdd($tok);
}


##############################################################################
#
#   LineFilter filter package
#
#   Tokenizer that recognizes lines.
#
#   Instance data:
#
#       buf         = unprocessed text
#
package LineFilter;
@LineFilter::ISA = qw(TokenFilter);

#
#   Recognize lines.
#
sub NextToken {
    my($self) = shift;

    if ($self->{buf} =~ s/([^\n]*\n)//) {
        $1;
    } else {
        undef;
    }
}

##############################################################################
#
#   WhitespaceFilter filter package
#
#   Removes blank lines and removes leading and trailing whitespace.
#
#   Someday: Collapse multiple whitespace outside of quotation marks.
#
package WhitespaceFilter;
@WhitespaceFilter::ISA = qw(LineFilter);

sub EachToken {
    my($self, $line) = @_;
    $line =~ s/^[ \t]+//;
    $line =~ s/[ \t]+$//;
    $self->SinkAdd($line) unless $line =~ /^$/;
}

##############################################################################
#
#   OutFile filter package
#
#   Writes its output to a file.
#
#   Instance data:
#
#       fh          = name of file handle
#
#

package OutFile;
@OutFile::ISA = qw(Filter);
no strict 'refs';           # Our filename globs aren't very strict

#
#   Custom method:  SetOutput.  Opens an output file.
#

my $seq = 0;

sub SetOutput {
    my($self, $file) = @_;
    $self->{fh} = "OutFile" . $seq++;
    open($self->{fh}, ">$file") || die "Unable to open $file for writing ($!)\n";
}

sub Add {
    my $self = shift;
    print { $self->{fh} }  @_;
}

sub Close {
    my $self = shift;
    close($self->{fh});
}

##############################################################################
#
#   DebugFilter filter package
#
#   Filters out ;debug and ;begin_debug blocks if building retail.
#
#   Instance data:
#
#       skip        = nonzero if we are inside an ignored ;begin_debug block
#       buf         = unprocessed text
#

package DebugFilter;
@DebugFilter::ISA = qw(LineFilter);
no strict 'refs';           # Our filename globs aren't very strict

#
#   See if the line contains a debug marker.
#   If applicable, send the line down the chain.
#
sub EachToken {
    my($self, $line) = @_;

    # ;begin_debug means start skipping if retail
    if ($line =~ s/;begin_debug//) {
        $self->{skip} = $::RetailVersion;
    }

    # If we were skipping, then ;end_debug ends skipping and we should eat it
    if ($line =~ s/;end_debug// && $self->{skip}) {
        $self->{skip} = 0;
    } elsif ($line =~ s/;debug// && $::RetailVersion) {
        # A one-shot debug line in retail - skip it
    } elsif (!$self->{skip}) {
        $self->SinkAdd($line);          # send it down the chain
    }
}

##############################################################################
#
#   CPP filter package
#
#   The CPP filter performs the following operations:
#
#       Removes C and C++-style comments.
#
#       Filters whitespace.
#
#   Instance data:
#
#       buf         = unprocessed text
#       wsf         = child WhitespaceFilter
#       script      = current script sink
#       ultSink     = the ultimate sink

package CPP;
@CPP::ISA = qw(TokenFilter);

sub new {
    my($class) = shift;
    my $self = new Filter;
    $self->{wsf} = new WhitespaceFilter;    # sink into a whitespace filter
    $self->{sink} = $self->{wsf};           # initially use this script
    bless $self, $class;
}

#
#   Recognize tokens, which are lines or /* ... */ comments.
#
sub NextToken {
    my($self) = shift;

    if ($self->{buf} =~ s/^([^\/]+)//) {    # eat up to a slash
        $1;
    } elsif ($self->{buf} =~ s/^\/\/.*?\n//) { # eat // to end of line
        "\n";
    } elsif ($self->{buf} =~ s/^\/\*[^\0]*?\*\///) { # eat /* .. */
        '';
    } elsif ($self->{buf} =~ s/^(\/)(?=[^\/\*])//) { # eat / not followed by / or *
        $1;
    } else {                                    # incomplete fragment - stop
        undef;
    }
}

#
#   SetSink
#
#   The sink we get is really the whitespace filter's sink, and we sink
#   into the whitespace filter.
#
sub SetSink {
    my ($self, $sink) = @_;
    $self->{wsf}->SetSink($sink);
}

##############################################################################
#
#
#   JS - comments are // or /* ... */, invoked via <SCRIPT>...
#   CSS - comments are /* ... */, invoked via <STYLE TYPE="text/css">
#
#   They are both just CPP thingies.  Both should someday remove whitespace

package JS;
@JS::ISA = qw(CPP);

package CSS;
@CSS::ISA = qw(CPP);

##############################################################################
#
#   HTML filter package
#
#   The HTML filter performs the following operations:
#
#       Send the final output through a whitespace filter.
#
#       Remove comments.
#
#   Someday it will also...
#
#       Recognize embedded stylesheets and scripts and generate a subfilter
#       to handle them.
#
#       Compress spaces outside quotation marks.
#
#   Instance data:
#
#       buf         = unprocessed text
#       wsf         = child WhitespaceFilter
#       script      = current script sink
#       endScript   = sub that recognizes end of script
#       ultSink     = the ultimate sink

package HTML;
@HTML::ISA = qw(TokenFilter);

sub new {
    my($class) = shift;
    my $self = new Filter;
    $self->{wsf} = new WhitespaceFilter;
    $self->{sink} = $self->{wsf};           # initially use this script
    bless $self, $class;
}

#
#   SetSink
#
#   The sink we get is really the whitespace filter's sink, and we sink
#   into the whitespace filter.
#
sub SetSink {
    my ($self, $sink) = @_;
    $self->{ultSink} = $sink;
    $self->{wsf}->SetSink($sink);
}

#
#   NextHTMLToken
#
#   An HTML token is one of the following:
#
#   -   A hunk of boring text.
#   -   A comment (thrown away).
#   -   A matched <...> thingie.

sub NextHTMLToken {
    my($self) = shift;

    #
    #   Any string of non "<" counts as a boring text token.
    #
    #   Be careful not to mistake <!DOCTYPE...> as a comment.
    #
    if ($self->{buf} =~ s/^([^<]+)//) {
        $1;
    } elsif ($self->{buf} =~ s/^(<!--[^\0]*?-->)//) {  # Eat full comments
        '';
    } elsif ($self->{buf} =~ s/^(<![^-][^>]*>)//) { # <!DOCTYPE ...>
        $1;
    } elsif ($self->{buf} =~ s/^(<[^!][^>]*>)//) { # <something else>
        $1;
    } else {                                    # incomplete fragment - stop
        undef;
    }
}

#
#   NextScriptToken
#
#   A script token is anything that isn't the word </SCRIPT>.
#

sub NextScriptToken
{
    my($self) = shift;
    if ($self->{buf} =~ s,^(</SCRIPT>),,i) {
        $1;
    } elsif ($self->{buf} =~ s,^(.*?)</SCRIPT>,,i) {
        $1;
    } else {
        my $tok = $self->{buf};
        $self->{buf} = '';
        $tok;
    }
}

#
#   NextToken
#
#   Returns either an HTML token or a script token.
#
sub NextToken {
    my($self) = shift;
    if (defined $self->{script}) {
        $self->NextScriptToken();
    } else {
        $self->NextHTMLToken();
    }
}

#
#   _Redirect - Private method that redirects parsing to a script language.
#
#       $self->_Redirect($scr, $end);
#
#       $scr = script object to hook in
#       $end = sub that recognizes the end of the script
#
#
sub _Redirect {
    my ($self, $scr, $end) = @_;
    $self->{script} = $self->{sink} = $scr;
    $scr->SetSink($self->{ultSink});
    $self->{endScript} = $end;
}

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

    if ($tok =~ /^<SCRIPT/i) {
        $self->{inScript} = 1; # BUGBUG create a script sink
        my $elem = new Element($tok);
        my $lang = lc $elem->Attr("LANGUAGE");
        my $scr;
        # No language implies JScript
        if (!defined($lang) || $lang eq 'jscript' || $lang eq 'javascript') {
            $scr = new CPP;
        } else {
            warn "Unknown script language [$lang]";
            # Just use the whitespace filter as the unknown script filter
            $scr = new WhitespaceFilter;
        }
        $self->_Redirect($scr, sub { m,^</SCRIPT>,i });

    } elsif ($tok =~ /<STYLE/i) {
        $self->_Redirect(new CSS, sub { m,^</STYLE>,i });

    } elsif (defined($self->{endScript}) && &{$self->{endScript}}($tok)) {
        delete $self->{endScript};
        $self->{script}->Flush();
        delete $self->{script};
        $self->{sink} = $self->{wsf};
    }
    $self->SinkAdd($tok);
}

##############################################################################
#
#   Main package
#

package main;

#
#   Set up some defaults.
#
my $force_type = undef;                 # do not force file type
$::RetailVersion = 1;                   # not the debugging version
my $outfile = undef;                    # output file not known yet
my %VAR = ();                           # No variables defined yet
my $verbose = undef;                    # not verbose mode

##############################################################################
#
#   CreateTypeFilter - Create a filter for the specified type.
#

my $types = {
    html    => sub { new HTML },        # HTML
    htm     => sub { new HTML },
    htx     => sub { new HTML },
    js      => sub { new JS },          # Javascript
    jsx     => sub { new JS },
    css     => sub { new CSS },         # Cascading style sheet
    csx     => sub { new CSS },
};

sub CreateTypeFilter {
    my $sub = $types->{lc shift};
    &$sub;
}

##############################################################################
#
#   Command line parsing
#

sub Usage {
    die "Usage: htmlcln [-t [html|js|css]] [-DVAR[=value]...] [-v] -o outfile infile\n";
}

#
#   AddDefine - Handle a -D command line option.
#
sub AddDefine {
    my $line = shift;
    if ($line =~ /=/) {
        $VAR{$`} = $';
    } else {
        $VAR{$line} = 1;
    }
}

sub ParseCommandLine {

    #
    #   Scream through the command line arguments.
    #

    while ($#ARGV >= 0 && $ARGV[0] =~ /^-(.)(.*)/) {
        # $1 - command
        # $2 - optional argument

        my($cmd, $val) = ($1, $2);

        shift(@ARGV);

        if ($cmd eq 't') {
            $val = shift(@ARGV) if $val eq '';
            $force_type = $val;
        } elsif ($cmd eq 'D') {
            AddDefine($val);
        } elsif ($cmd eq 'o') {
            $val = shift(@ARGV) if $val eq '';
            $outfile = $val;
        } elsif ($cmd eq 'v') {
            $verbose = 1;
        } else {
            Usage();
        }
    }

    #
    #   What's left should be a filename, and there should be an output file.
    #

    my $infile = shift(@ARGV);
    Usage() unless defined $infile && defined $outfile && $#ARGV == -1;

    #
    #   If the filetype is not being overridden, then take it from the filename.
    #
    if (!defined $force_type) {
        ($force_type) = $infile =~ /\.(.*)/;
    }

    #
    #   Include debug goo only if building DBG=1 and FULL_DEBUG is set in the
    #   environment.
    #
    $::RetailVersion = 0 if defined($VAR{"DBG"}) && defined($ENV{"FULL_DEBUG"});

    $infile;
}

##############################################################################
#
#   File processing
#

sub ProcessFile {
    my $infile = shift;

    #
    #   Create the final sink.
    #
    my $sink = new OutFile;
    $sink->SetOutput($outfile);

    #
    #   Set up the default filter based on the file type.
    #
    my $Type = CreateTypeFilter($force_type);
    $Type->SetSink($sink);

    #
    #   Create the DebugFilter which sits at the top of the chain.
    #
    my $Filter = new DebugFilter;
    $Filter->SetSink($Type);

    #
    #   All the plumbing is ready - start pumping data.
    #
    open(I, $infile) || die "Cannot open $infile for reading ($!)\n";

    while (<I>) {
        $Filter->Add($_);
    }
    $Filter->Flush();
    $Filter->Close();
}

##############################################################################
#
#   Main program
#

{
    my $infile = ParseCommandLine();
    ProcessFile($infile);
}