File Coverage

blib/lib/SystemC/Vregs/Input/TableExtract.pm

Criterion	Covered	Total	%
statement	39	177	22.0
branch	2	64	3.1
condition	0	27	0.0
subroutine	7	13	53.8
pod	5	7	71.4
total	53	288	18.4

# See copyright, etc in below POD section.
######################################################################

package SystemC::Vregs::Input::TableExtract;

use base qw(HTML::TableExtract);
$VERSION = '1.470';

use strict;
use vars qw($Debug %Find_Start_Headers %Find_Headers);
use IO::File;
use HTML::TableExtract;
use HTML::Entities ();

%Find_Start_Headers = (Class=>1,
		       Package=>1,
		       Defines=>1,
		       Enum=>1,
		       Register=>1,
		       Vregs_End_Of_Decl=>1,
		       );
%Find_Headers = (%Find_Start_Headers,
		 Address=>1,
		 Attributes=>1,
		 );

######################################################################
#### Parsing

sub parse_file {
    my $self = shift;
    my $filename = shift;

    print "parse_file $filename\n" if $Debug;
    my $fh = IO::File->new ($filename) or die "%Error: $! $filename\n";
    $self->{_fh} = $fh;
    $self->{_vregs_filename} = $filename;
    $self->{_vregs_num_tables} = -1;
    $self->{_vregs_line} = 1;
    $self->{_format} = '';   #latex2html

    # Track line numbers
    $self->handler(start => "start", "self,tagname,attr,attrseq,text,line");

    # I've had lots of problems with parse_file missing stuff and not handling
    # chunks breaking in the middle of HTML objects.  So, we read it ourself.
    # $self->SUPER::parse_file ($fh);
    $self->parse(join('',$fh->getlines()));

    $self->eof();
    $self->start("p");
    $self->text("Vregs_End_Of_Decl");
    $fh->close();
    print "parse_file DONE\n" if $Debug;
}

sub clean_html_text {
    $_ = shift;
    # HTML escapes to normal Latin1 ASCII
    $_ = HTML::Entities::decode($_);
    # Hack: Decode two-byte UTF-8 chars without checking that the HTML body
    # uses UTF-8 encoding.  wvHtml writes HTML in UTF-8 encoding when the
    # .doc file comes from StarOffice7.
    s{[\302\303].}{
	my ($a, $b) = unpack("CC", $&);
	(($b & 0xC0) != 0x80 ? $&	# Not a 2-byte UTF-8 char.
	 : pack("C", ($a & 0x3)<<6 | ($b & 0x3f) ))
    }eg;
    # Latin1 decoding
    # Substituting 2 or 3 periods for 'elipses' causes Vspecs to truncate
    # the field description at the periods, so use dashes.
    s/\205/-/g;		# ISO-Latin1 horizontal elipses (0x85)
    s/\221/\'/g;	# ISO-Latin1 left single-quote
    s/\222/\'/g;	# ISO-Latin1 right single-quote
    s/\223/\"/g;	# ISO-Latin1 left double-quote
    s/\224/\"/g;	# ISO-Latin1 right double-quote
    s/\225/\*/g;	# ISO-Latin1 bullet
    s/\226/-/g;		# ISO-Latin1 en-dash (0x96)
    s/\227/-/g;		# ISO-Latin1 em-dash (0x97)
    s/\230/~/g;		# ISO-Latin1 small tilde
    s/\233/>/g;		# ISO-Latin1 single right angle quote
    s/\240/ /g;		# ISO-Latin1 nonbreaking space
    s/\246/\|/g;	# ISO-Latin1 broken vertical bar
    s/\255//g;		# ISO-Latin1 soft hyphen (0xAD)
    s/\264/\'/g;	# ISO-Latin1 spacing acute
    s/\267/\*/g;	# ISO-Latin1 middle dot (0xB7)
    s/\327/\*/g;# x multiplication

    # These are automatically removed by HTML::Entities in Perl 5.7 and greater
    # Also decode unicode sequences decoded by perl 5.8.*
    s/\&\#8209;/-/g;    # ISOpub nonbreaking hyphen (U+2011, ‑)
    s/\&\#8211;/-/g;    s/\–/-/g;  s/\342\200\041/\-/g;   # ISOpub en-dash (U+2013, –)
    s/\&\#8212;/-/g;    s/\—/-/g;  s/\342\200\042/\-/g;   # ISOpub em-dash (U+2014, —)
    s/\&\#8216;/\'/g;   s/\‘/\'/g; s/\342\200\176/\`/g;   # ISOnum left single-quote (U+2018, ‘)
    s/\&\#8217;/\'/g;   s/\’/\'/g; s/\342\200\177/\`/g;   # ISOnum right single-quote (U+2019, ’)
    s/\&\#8230;/-/g;    s/\…/-/g; s/\342\200\174/-/g;    # ISOpub horizontal elipses (U+2026, …)
    ;                                    s/(\342\200\230|\x{2018})/\`/g;   # ISOnum left single-quote (U+2018, ‘)
    ;                                    s/(\342\200\231|\x{2019})/\`/g;   # ISOnum right single-quote (U+2019, ’)
    s/\&\#8220;/\"/g;   s/\“/\"/g; s/(\342\200\234|\x{201c})/\"/g;   # ISOnum left double-quote (U+201C, “)
    s/\&\#8221;/\"/g;   s/\”/\"/g; s/(\342\200\235|\x{201d})/\"/g;   # ISOnum right double-quote (U+201D, ”)
    ;                                    s/(\342\210\222|\x{2212})/-/g;    # ISOpub horizontal elipses (U+2026, …)

    # Compress spacing
    s/\`/\'/g;
    s/[\t\n\r ]+/ /g;
    s/^ *//g;
    return $_;
}

sub start {
    my $self = shift;
    $self->{_vregs_line} = $_[4] if $_[4] && !$self->{_vregs_forced_line};  # As we have a handler requesting it
    if ($_[0] eq 'p' || $_[0] =~ /^h[0-9]/) {
	#print "\n" if $Debug;
	$self->{_vregs_first_word_in_p} = 1;
	if ($self->{_format} eq 'latex2html'   # Latex2html doesn't do any 's
	    && $self->{_vregs_next_tag}
	    && $self->{_vregs_next}{$self->{_vregs_next_tag}} ne "") {
	    $self->{_vregs_next_tag} = undef;
	}
    }
    if ($_[0] eq 'meta' && $_[1]->{content} && $_[1]->{content} =~ /latex2html/i) {
	$self->{_format} = 'latex2html';
	print "Format = latex2html\n" if $Debug;
    }
    $self->SUPER::start (@_);
}

sub comment {
    my $self = shift;
    my $text = shift;
    if ($text =~ /^\s*line\s+(\d+)\s+"(.*)"/) {
	$self->{_vregs_forced_line} = $1;
	$self->{_vregs_line} = $1;
	$self->{_vregs_filename} = $2;
    }
}

sub end {
    my $self = shift;
    if ($_[0] eq 'p') {
	print "<\/$_[0]>\n" if $Debug;
	if (!$self->{_vregs_first_endp}) {
	    $self->{_vregs_first_endp} = 1;
	} else {
	    $self->{_vregs_next_tag} = undef;
	}
    }
    $self->SUPER::end (@_);
}

sub text {
    my $self = shift;
    # Don't bother if we are in a table
    if (! $self->{_in_a_table}) {
	my $text = $_[0];
	if ($Debug) {
	    (my $printtext = $text) =~ s/[\n \t]+/ /g;
	    printf +("Text %s: %s:|%s|\n", $self->{_vregs_line},
		     ($self->{_vregs_first_word_in_p}?"FW":"  "),$printtext);
	}
	$text = clean_html_text($text);
	if ($text !~ /^\s*$/
	    && $text !~ /^
	    my $nosp_text = $text;
	    if ($self->{_vregs_first_word_in_p}) {
		$nosp_text =~ s/^\s+//; $nosp_text =~ s/\s+$//;
		# Per W3C HTML spec, "SGML specifies that a line break immediately
		# following a start tag must be ignored, as must a line break
		# immediately before an end tag.  This applies to all HTML elements
		# without exception."
		# And, "For all HTML elements except PRE, sequences of white space
		# separate words."
		# Sadly, the HTML parser did not take care of this for us.
		$text = $nosp_text;
	    }
	    if ($self->{_vregs_first_word_in_p}
		&& $Find_Headers{$nosp_text}) {
		print "Keyword '$text'\n" if $Debug;
		if ($Find_Start_Headers{$text}
		    && $self->{_vregs_next}) {
		    # Process previous entry, and prepare for next discovery
		    my $inp = $self->{_vregs_inp};
		    $inp->new_item([], $self->{_vregs_next});  # note no table
		    $self->{_vregs_next} = undef;
		}
		$self->{_vregs_next}{at} = ($self->{_vregs_filename}.":".$self->{_vregs_line});
		$self->{_vregs_next_tag} = $text;
                $self->{_vregs_next}{$self->{_vregs_next_tag}} = "";
                $self->{_vregs_first_endp} = 0;
                $self->{_vregs_next} = undef if $text eq 'Vregs_End_Of_Decl';
		$self->{_vregs_next_tag} = undef if $text eq 'Vregs_End_Of_Decl';
	    }
	    elsif ($self->{_vregs_next_tag}) {
		print "TAG '$self->{_vregs_next_tag}' '$text'\n" if $Debug;
		$self->{_vregs_next}{$self->{_vregs_next_tag}} .= $text;
	    }
	}
	$self->{_vregs_first_word_in_p} = 0 if ($text !~ /^\s*$/);
	my @tables = $self->table_states();
	my $numtables = ();
	if ($#tables != $self->{_vregs_num_tables}) {
	    $self->{_vregs_num_tables} = $#tables;
	    if ($self->{_vregs_next}) {  # else a table outside of a register decl
		my $table = $tables[$#tables];
		# Clean up the table to remove extra spaces in the tables
		my @bittable = ($table->rows);
		foreach my $row (@bittable) {
		    @$row = map {
			$_ = '' if !defined $_;  # TableExtract may return '' if empty column
			$_ = clean_html_text($_);
			# The below isn't quite right, as a < will become a < by the extractor
			$_ =~ s/<[^>]+>//ig; #$_="" if /SupportEmptyParas/i;  # Microsloth Word junk
			$_ =~ s/^[ \t\n\r]+//sig;
			$_ =~ s/[ \t\n\r]+$//sig;
			$_;
		    } @$row;
		}
		# Process this, and prepare for next discovery
		my $inp = $self->{_vregs_inp};
		print ::Dumper(\@bittable, $self->{_vregs_next}) if $Debug;
		$inp->new_item(\@bittable, $self->{_vregs_next});
		$self->{_vregs_next} = undef;
		$self->{_vregs_next_tag} = undef;
	    }
	}
    }
    $self->SUPER::text (@_);
}

######################################################################
#### HTML cleaning

sub clean_html_file {
    my $filename = shift;
    # Word puts so much XML &*(#@$ in the file... Strip it so it's more obvious.

    my $wholefile;
    {
	my $fh = IO::File->new($filename) or die "%Error: $! $filename\n";
	local $/;
	undef $/;
	$wholefile = <$fh>;
	$fh->close;
    }

    $wholefile =~ s%\r%%smg;
    $wholefile =~ s%%%smg;
    $wholefile =~ s%[ \n]style='.*?'%%smg;
    $wholefile =~ s%[ \n]style=".*?"%%smg;
    $wholefile =~ s% border=0 % border=1 %smg;
    $wholefile =~ s%<\/?span\s*>%%smg;
    $wholefile =~ s%<\/?o:p>%%smg;
    $wholefile =~ s% width=\d+ % %smg;
    $wholefile =~ s%\ %%smg;

    # Microsoft Word changebars
    $wholefile =~ s%\[Author\s+\S+:\s+at\s+\S+\s+\S+\s+\d+\s+\S+\s+\d+\s*\]\s*%%smg;

    my $fh = IO::File->new($filename,"w") or die "%Error: $! writing $filename\n";
    print $fh $wholefile;
    $fh->close;
}

######################################################################
#### Package return
1;
__END__