#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

use strict;
require Exporter;

$W3C::Registration::Texifyer::REVISION = '$Id: Texifyer.pm,v 1.12 2000/09/29 17:17:40 eric Exp $ ';

package W3C::Registration::Texifyer;
use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK);
@ISA = ();
@EXPORT = ();
@EXPORT_OK = qw();
$VERSION = 0.91;
$DSLI = 'adpO';

# todo:
#  state becomes a stack with ul and the like or'd and pushed
#  support dl dd dt

use strict;
use HTML::Parser;

package FAKE::HTML::Parser;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless ($self, $class);
    return $self;
}

# sub HTML::Entities::decode {
#     return CGI::unescapeHTML($_[0]);
# }

package W3C::Registration::FastHTMLParser;

@W3C::Registration::FastHTMLParser::ISA = ('HTML::Parser');

sub parse
{
    my $self = shift;
    my $buf = \ $self->{'_buf'};
    unless (defined $_[0]) {
	# signals EOF (assume rest is plain text)
	$self->text($$buf) if length $$buf;
	$$buf = '';
	return $self;
    }
    $$buf .= $_[0];
    my $netscape_comment = !$self->{'_strict_comment'};

    # Parse html text in $$buf.  The strategy is to remove complete
    # tokens from the beginning of $$buf until we can't deside whether
    # it is a token or not, or the $$buf is empty.

  TOKEN:
    while (1) {

	# First we try to pull off any plain text (anything before a "<" char)
	if ($$buf =~ m/\G ([^<]+) /gcxs) {
	    if (pos $$buf < length $$buf) {
		$self->text($1);
	    } else {
		my $text = $1;
		# At the end of the buffer, we should not parse white space
		# but leave it for parsing on the next round.
		if ($text =~ s|(\s+)$||) {
		    $$buf = $1;
		    pos $$buf = 0;
                # Same treatment for chopped up entites and words.
		# We must wait until we have it all.
		} elsif ($text =~ s|(\s*\S+)$||) {
		    $$buf = $1;
		    pos $$buf = 0;
		};
		$self->text($text) if (pos $$buf < length $text);
		last TOKEN;
	    }

	# Netscapes buggy comments are easy to handle
	} elsif ($netscape_comment && $$buf =~ m/\G <!-- /gcxs) {
	    if ($$buf =~ m/\G (.*?) --> /gcxs) {
		$self->comment($1);
	    } else {
		last TOKEN;  # must wait until we see the end of it
	    }

	# Then, markup declarations (usually either <!DOCTYPE...> or a comment)
	} elsif ($$buf =~ m/\G (<!) /gcxs) {
	    my $eaten = $1;
	    my $text = '';
	    my @com = ();  # keeps comments until we have seen the end
	    # Eat text and beginning of comment
	    while ($$buf =~ m/\G (([^>]*?) --) /gcxs) {
		$eaten .= $1;
		$text .= $2;
		# Look for end of comment
		if ($$buf =~ m/\G ((.*?)--) /gcxs) {
		    $eaten .= $1;
		    push(@com, $2);
		} else {
		    # Need more data to get all comment text.
		    $$buf = $eaten . substr($$buf, pos $$buf);
		    pos $$buf = 0;
		    last TOKEN;
		}
	    }
	    # Can we finish the tag
	    if ($$buf =~ m/\G ([^>]*)> /gcxs) {
		$text .= $1;
		$self->declaration($text) if $text =~ /\S/;
		# then tell about all the comments we found
		for (@com) { $self->comment($_); }
	    } else {
		$$buf = $eaten . substr($$buf, pos $$buf);  # must start with it all next time
		pos $$buf = 0;
		last TOKEN;
	    }

        # Should we look for 'processing instructions' <? ...> ??
	#} elsif ($$buf =~ s|<\?||) {
	    # ...

	# Then, look for a end tag
	} elsif ($$buf =~ m/\G <\/ /gcxs) {
	    # end tag
	    if ($$buf =~ m/\G ([a-zA-Z][a-zA-Z0-9\.\-]*)(\s*>) /gcxs) {
		$self->end(lc($1), "</$1$2");
	    } elsif ($$buf =~ m/\G ([a-zA-Z]*[a-zA-Z0-9\.\-]*\s*)\Z /gcxs) {
		$$buf = "</" . $1;  # need more data to be sure
		pos $$buf = 0;
		last TOKEN;
	    } else {
		# it is plain text after all
		$self->text("</");
	    }

	# Then, finally we look for a start tag
	} elsif ($$buf =~ m/\G (<([a-zA-Z]+)>) /gcxs) {
	    # special case plain start tags for slight speed-up (2.5%)
	    $self->start(lc($2), {}, [], $1);

	} elsif ($$buf =~ m/\G < /gcxs) {
	    # start tag
	    my $eaten = '<';

	    # This first thing we must find is a tag name.  RFC1866 says:
	    #   A name consists of a letter followed by letters,
	    #   digits, periods, or hyphens. The length of a name is
	    #   limited to 72 characters by the `NAMELEN' parameter in
	    #   the SGML declaration for HTML, 9.5, "SGML Declaration
	    #   for HTML".  In a start-tag, the element name must
	    #   immediately follow the tag open delimiter `<'.
	    if ($$buf =~ m/\G (([a-zA-Z][a-zA-Z0-9\.\-]*)\s*) /gcxs) {
		$eaten .= $1;
		my $tag = lc $2;
		my %attr;
		my @attrseq;

		# Then we would like to find some attributes
                #
                # Arrgh!! Since stupid Netscape violates RCF1866 by
                # using "_" in attribute names (like "ADD_DATE") of
                # their bookmarks.html, we allow this too.
		while ($$buf =~ m/\G (([a-zA-Z][a-zA-Z0-9\.\-_]*)\s*) /gcxs) {
		    $eaten .= $1;
		    my $attr = lc $2;
		    my $val;
		    # The attribute might take an optional value (first we
		    # check for an unquoted value)
		    if ($$buf =~ m/\G (=\s*([^\"\'>\s][^>\s]*)\s*) /gcxs) { # EGP was s|(^=...
			$eaten .= $1;
			$val = $2;
			HTML::Entities::decode($val);
		    # or quoted by " or '
		    } elsif ($$buf =~ m/\G(=\s*([\"\'])(.*?)\2\s*) /gcxs) { # EGP was s|(^=...
			$eaten .= $1;
			$val = $3;
			HTML::Entities::decode($val);
                    # truncated just after the '=' or inside the attribute
		    } elsif ($$buf =~ m/\G (=\s*) \Z/gcxs ||
			     $$buf =~ m/\G (=\s*[\"\'].*) /gcxs) { # EGP was m|...|s
			$$buf = "$eaten$1";
			pos $$buf = 0;
			last TOKEN;
		    } else {
			# assume attribute with implicit value
			$val = $attr;
		    }
		    $attr{$attr} = $val;
		    push(@attrseq, $attr);
		}

		# At the end there should be a closing ">"
		if ($$buf =~ m/\G > /gcxs) {
		    $self->start($tag, \%attr, \@attrseq, "$eaten>");
		} elsif (pos $$buf < length $$buf) {
		    # Not a conforming start tag, regard it as normal text
		    $self->text($eaten);
		} else {
		    $$buf = $eaten;  # need more data to know
		    pos $$buf = 0;
		    last TOKEN;
		}

	    } elsif (pos $$buf < length $$buf) {
		$self->text($eaten);
	    } else {
		$$buf = $eaten . substr($$buf, pos $$buf);  # need more data to parse
		pos $$buf = 0;
		last TOKEN;
	    }

	} else {
	    #die if length $$buf > pos $$buf;	# This should never happen
	    last TOKEN;				# The buffer should be empty now
	}
    }

    $self;
}

package W3C::Registration::Texifyer;

@W3C::Registration::Texifyer::ISA = ('W3C::Registration::FastHTMLParser');

*W3C::Registration::Texifyer::OUTSIDE = \1;
*W3C::Registration::Texifyer::HN = \2;
*W3C::Registration::Texifyer::PRE = \3;
*W3C::Registration::Texifyer::PRINTTAGS = \0;
*W3C::Registration::Texifyer::TABLE = \4;
*W3C::Registration::Texifyer::TABLER = \5;
*W3C::Registration::Texifyer::TABLED = \6;
*W3C::Registration::Texifyer::SELECT = \7;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $width = shift;
    my $depthTab = shift;
    my $self = $class->SUPER::new(@_);
    $self->{WIDTH} = $width;
    $self->{DEPTHTAB} = $depthTab;
    bless ($self, $class);
    $self->clear;
    return $self;
}

sub clear {
    my $self = shift;
    $self->{DEPTH} = 0;
    $self->{X} = 0;
    $self->{Y} = 0;
    $self->{TEXT} = '';
    $self->{TAG_STACK} = [];
    $self->pushState($W3C::Registration::Texifyer::OUTSIDE);
}

# <p>, <li>, <dt>, <dd>, <head>, <body>, <tr>, <td>, <option>, <input>

sub pushState {
    my ($self, $newState) = (@_);
    pop @{$self->{TAG_STACK}} if (@{$self->{TAG_STACK}} =~ m/\A(p|li|dr|dd|head|body|tr|td|option|input)\Z/);
    push @{$self->{TAG_STACK}}, $newState;
}

sub popState {
    my ($self, $matchTag) = (@_);
    return pop @{$self->{TAG_STACK}};
}

sub state {
    my ($self) = (@_);
    return @{$self->{TAG_STACK}}[-1];
}

sub text {
    my($self, $text) = @_;
    # $text =~ s/\&nbsp\;/ /g;
    $text = HTML::Entities::decode($text);
    if ($self->state == $W3C::Registration::Texifyer::TABLED) {
	$self->tableCellText($text);
    } elsif ($self->state == $W3C::Registration::Texifyer::SELECT) {
	$self->selectText($text);
    } else {
	$self->filterWhitespace($text);
    }
}

sub filterWhitespace {
    my $self = shift;
    my $text = shift;
    while ($text =~ m/\G ((\S+)|(\s+)) /gcxsi) {
	my $chars = $1;
	if ($self->state == $W3C::Registration::Texifyer::PRE) {
	    $self->addAtom($chars, 1);
	} else {
	    $self->addAtom($chars, 0) if ($chars !~ m/\s+/ || $self->{TEXT} !~ /\s\Z/);
	}
    }
}

sub addAtom {
    my $self = shift;
    my $text = shift;
    my $litteral = shift;
    $text =~ s/\s+/ /g if (!$litteral);
    my $len = length($text);
    if (!$litteral && $len + $self->{X} > $self->{WIDTH}) {
	$self->{TEXT} =~ s/[ \t]*\Z//;
	$self->nl;
	$text =~ s/\A\s*//;
	$len = length($text);
    }
    $text = HTML::Entities::decode($text);
    $self->{TEXT} .= $text; # @@@ very expensive way to store results
    $self->{X} += $len;
}

sub nl {
    my $self = shift;
    $self->{TEXT} .= "\n" . ' ' x ($self->{DEPTH} * $self->{DEPTHTAB});
    $self->{X} = $self->{DEPTH} * $self->{DEPTHTAB};
    $self->{Y}++;
}

sub tab {
    my $self = shift;
    my $tab = shift;
    $self->{TEXT} .= ' ' x $tab;
    $self->{X} = $tab;
}

sub lf {
    my $self = shift;
    $self->nl if ($self->{TEXT} !~ m/\n\Z/);
}

sub lflf {
    my $self = shift;
    return if ($self->{TEXT} =~ m/\n\n\Z/);
    $self->nl if ($self->{TEXT} !~ m/\n\Z/);
    $self->nl;
}

sub addDepth {
    my $self = shift;
    my $depth = shift;
    $self->{DEPTH} += $depth;
}

sub clearStandard {
    my $self = shift;
    if ($self->state == $W3C::Registration::Texifyer::DD | 
	$self->state == $W3C::Registration::Texifyer::DT) {
	$self->popState;
	$self->addDepth(-1);
    }
}

sub startTable {
    my $self = shift;
    $self->{CELL_ROW} = 0;
    $self->{CELL_COL} = 0;
    $self->{CELL_WIDTHS} = [];
    $self->{CELL_DATA} = [];
}

sub startTableRow {
    my $self = shift;
}

sub startTableCell {
    my $self = shift;
}

sub tableCellText {
    my ($self, $text) = @_;
    my $pData = \$self->{CELL_DATA}[$self->{CELL_ROW}][$self->{CELL_COL}];
    $text = HTML::Entities::decode($text);
    $$pData .= $text;
    my $pWidth = \$self->{CELL_WIDTHS}[$self->{CELL_COL}];
    $$pWidth = length $$pData if (length $$pData > $$pWidth);
}

sub endTableCell {
    my $self = shift;
    $self->{CELL_COL}++;
}

sub endTableRow {
    my $self = shift;
    $self->{CELL_ROW}++;
    $self->{CELL_COL} = 0;
}

sub endTable {
    my $self = shift;
    $self->lf;
    foreach my $row (@{$self->{CELL_DATA}}) {
	my $colNo = 0;
	foreach my $col (@{$row}) {
	    $self->addAtom($col, 1);
	    $self->tab($self->{CELL_WIDTHS}[$colNo] - length($col) + 2); # two space buffer for for column visibility
	    $colNo++;
	}
	$self->nl;
    }
    $self->lf;
}

sub selectText {
    my ($self, $text) = @_;
    return if (!$self->{SELECTED});
    $self->{SELECTED} = 0;
    $self->popState;
    chomp $text;
    $text = HTML::Entities::decode($text);
    $self->text($text);
    $self->pushState($W3C::Registration::Texifyer::SELECT);
}

# get real rules from
# grep -h '\- *O' /usr/local/lib/sgml/REC-html40-971218/[ls]*

sub start
{
    my($self, $tag, $attr, $attrseq, $origtext) = @_;
    # $attr is reference to a HASH, $attrseq is reference to an ARRAY
    if ($W3C::Registration::Texifyer::PRINTTAGS) {
	print '<', $tag;
	foreach my $singleAttr (@$attrseq) {
	    print ' ', $singleAttr;
	}
	print '>', "\n";
    }
    if ($tag =~ m/\Ah(\d)\Z/i) {
	$self->lflf;
	$self->tab($1);
	$self->pushState($W3C::Registration::Texifyer::HN);
    } elsif ($tag eq 'title') {
	$self->lflf;
	$self->pushState($W3C::Registration::Texifyer::HN);
    } elsif ($tag eq 'ul') {
	$self->addDepth(1);
    } elsif ($tag eq 'li') {
	$self->nl;
	$self->addAtom(('x ', 'o ', '. ')[$self->{DEPTH}%3 - 1], 1);
    } elsif ($tag eq 'br') {
	$self->lf;
    } elsif ($tag eq 'p') {
	$self->lflf;
    } elsif ($tag eq 'dl') {
	$self->lflf;
    } elsif ($tag eq 'dt') {
	$self->lf;
    } elsif ($tag eq 'dd') {
	$self->pushState($W3C::Registration::Texifyer::DD);
	$self->addDepth(1);
    } elsif ($tag eq 'hr') {
	$self->lflf;
	$self->addAtom('-' x $self->{WIDTH}, 1);
	$self->nl;
    } elsif ($tag eq 'pre') {
	$self->pushState($W3C::Registration::Texifyer::PRE);
    } elsif ($tag eq 'table') {
	$self->lf;
	$self->startTable;
	$self->pushState($W3C::Registration::Texifyer::TABLE);
    } elsif ($tag eq 'tr') {
	$self->startTableRow;
	$self->pushState($W3C::Registration::Texifyer::TABLER);
    } elsif ($tag eq 'td') {
	$self->startTableCell;
	$self->pushState($W3C::Registration::Texifyer::TABLED);
    } elsif ($tag eq 'input') {
	if ($attr->{'type'} eq 'hidden') {
	} elsif ($attr->{'type'} eq 'checkbox') {
	    $self->text($attr->{'checked'} ? ' X ' : ' _ ');
	} else {
	    $self->text($attr->{'value'});
	}
    } elsif ($tag eq 'select') {
	$self->pushState($W3C::Registration::Texifyer::SELECT);
    } elsif ($tag eq 'option') {
	$self->{SELECTED} = 1 if ($attr->{'selected'});
    }

}

sub end
{
    my($self, $tag, $origtext) = @_;
    if ($W3C::Registration::Texifyer::PRINTTAGS) {
	print '</', $tag, '>', "\n";
    }
    if ($tag =~ m/h(\d)/i) {
	$self->lflf;
	$self->popState($tag);
    } elsif ($tag eq 'title') {
	$self->lflf;
	$self->popState($tag);
    } elsif ($tag eq 'ul') {
	$self->addDepth(-1);
    } elsif ($tag eq 'p') {
	$self->nl;
    } elsif ($tag eq 'dd') {
	$self->popState($tag);
	$self->addDepth(-1);
    } elsif ($tag eq 'pre') {
	$self->popState($tag);
    } elsif ($tag eq 'table') {
	$self->endTable;
	$self->popState($tag);
    } elsif ($tag eq 'td') {
	$self->endTableCell;
	$self->popState($tag);
    } elsif ($tag eq 'tr') {
	$self->endTableRow;
	$self->popState($tag);
    } elsif ($tag eq 'select') {
	$self->popState($tag);
    }
}

sub getText {
    my $self = shift;
    return $self->{TEXT};
}

