# -*-perl-*-
# $Id: dom.wrt 5748 2008-12-02 20:10:35Z mnodine $
# Copyright (C) 2002-2005 Freescale Semiconductor, Inc.
# Distributed under terms of the Perl license, which is the disjunction of
# the GNU General Public License (GPL) and the Artistic License.

# Writer for debugging internal structures.

=pod
=begin reST
=begin Description
This writer dumps out the internal Document Object Model (DOM, also
known as a doctree) in an indented format known as pseudo-XML.  It
is useful for checking the results of the parser or transformations.
It recognizes the following defines:

-W nobackn      Disables placing "\\n\\" at ends of lines that would
                otherwise end in whitespace.
=end Description
=end reST
=cut

sub BEGIN {
    # My -W flags
    use vars qw($nobackn);
    
    # Defaults for -W flags
    $nobackn = 0 unless defined $nobackn;

    # Globals
    use vars qw(%QUOTE);
    %QUOTE = ('<'=>'lt', '>'=>'gt', '"', 'quot');
}

# Returns an equal sign and a quoted attribute from a list of attribute values
sub quote_attr {
    my (@attr) = @_;
    foreach (@attr) {
	s/([<>\"])/&$QUOTE{$1};/g;
	# uncoverable statement count:3
	# uncoverable statement count:4
	# uncoverable statement count:5
	s/([\x00-\x09\x0b-\x1f\x7f-\xff\x{0100}-\x{ffff}])/sprintf '\u%04x', ord $1/ge;
    }
    qq(="@attr");
}

phase PROCESS {
    sub \#PCDATA = {
	my ($dom, $str) = @_;
	my $text = $dom->{text};
	if (! $nobackn) {
	    $text =~ s/\n\n/\n\\n\\\n/g;
	    $text =~ s/ $/ \\n\\/;
	}
	$text .= "\n" unless substr($dom->{text},-1) eq "\n";
	$text =~ s/([\x00-\x09\x0b-\x1f\x7f-\xff\x{0100}-\x{ffff}])/sprintf '\u%04x', ord $1/ge;
	return $text;
    }

    sub mathml {
	my ($dom, $str) = @_;
	return $dom->{attr}{mathml} ? $dom->{attr}{mathml}->text . "\n" : $str;
    }

    sub .* = {
	my ($dom, $str, $writer) = @_;
	# Devel::Cover condition 0 0 $str should always be defined
	# uncoverable condition left note:$str should always be defined
	$str =~ s/^/    /mg if defined $str && $str ne '';
	my $attr = defined $dom->{attr} ?
	    join('',map(qq( $_) . (! defined $dom->{attr}{$_} ? '' :
				   ref($dom->{attr}{$_}) eq 'ARRAY' ?
				   quote_attr(@{$dom->{attr}{$_}}) :
				   quote_attr($dom->{attr}{$_})),
			sort keys %{$dom->{attr}})) : '';
	my $internal = '';
	# Devel::Cover condition 0 1 internal defined implies non-empty hash
	# uncoverable condition right note:internal defined => non-empty hash
	if (defined $dom->{internal} && %{$dom->{internal}}) {
            my $int = $dom->{internal};
	    $internal = "    .. internal attributes:\n";
            my $spaces = (" " x 9);
            $internal .= "$spaces.transform: $int->{'.transform'}\n";
	    $internal .= "$spaces.details:\n";
	    my $key;
	    foreach $key (sort keys %{$int->{'.details'}}) {
		my $val = $int->{'.details'}{$key};
		my $string;
		if (ref($val) eq 'Text::Restructured::DOM') {
                    $string = $writer->ProcessDOMPhase($val, 'PROCESS');
		    $string =~ s/^/$spaces    /mg;
		    $string = "\n$string";
		} 
		elsif ($val eq "") { $string = " None\n" }
		else { $string = " $val\n" }
		$internal .= "$spaces  $key:$string";
	    }
	}
	return "<${\$dom->tag}$attr>\n$str$internal";
    }
}