source: main/trunk/package-kits/scripts/perllib/Greenstone/XML/Tidy.pm

package Greenstone::XML::Tidy;

use strict;
use warnings;
use utf8;
use XML::Parser;
use POSIX 'isatty';
use Hash::Ordered;
use base 'Exporter';

our $VERSION = 1.00;
our @EXPORT = ( 'read_xml', 'write_xml' );
 
# Reads the servlets partial XML file using XML::Parser,
# Then converts the obtained data structure to a more readable one
# Example conversion:
=xml
<servlet>
  <servlet-name>library</servlet-name>
  <description attribute="example">The standard gsdl3 library program</description>
  <servlet-class>org.greenstone.gsdl3.LibraryServlet</servlet-class>
  <init-param>
    <param-name>library_name</param-name>
    <param-value>library</param-value>
  </init-param>
  <init-param>
    <param-name>site_name</param-name>
    <param-value>localsite</param-value>
  </init-param>
</servlet>
=cut
=data_structure
{
    'servlet' => {
        'servlet-class' => 'org.greenstone.gsdl3.LibraryServlet',
        'servlet-name' => 'library',
        'description' => {
            '.value' => 'The standard gsdl3 library program',
            '.attr' => {
                'attribute' => 'example'
            }
        },
        'init-param' => [
            {
                'param-value' => 'library',
                'param-name' => 'library_name'
            },
            {
                'param-name' => 'site_name',
                'param-value' => 'localsite'
            }
        ]
    }
}
=cut
sub read_xml {
    my $file = shift;
    my $xml;
    if ($file eq '-') {
        if (isatty *STDIN) {
            print STDERR "Reading XML from STDIN. Press ^D to end\n";
        }
        local $/ = undef;
        $xml = '<__root__>' . <STDIN> . '</__root__>';
    } else {
        $xml = '<!DOCTYPE doc [<!ENTITY real_doc SYSTEM "' . $file . '">]>
                <__root__>&real_doc;</__root__>';
    }
    # Parse the data using XML::Parser
    my $data = new XML::Parser (Style => 'Tree')->parse ($xml);

    sub tidy {
        my $hash = Hash::Ordered->new;
        # If the element has attributes, add them to the hash
        my $attr = shift;
        if (scalar keys %$attr > 0) {
            my $attr_ordered = Hash::Ordered->new;
            for my $key (keys %$attr) {
                $attr_ordered->set ($key => $attr->{$key});
            }
            $hash->set ('.attr' => $attr_ordered);
        }
        # Read any child elements or text value
        while (@_) {
            my $element = shift;
            my $value   = shift;
            if ($element eq 0) {
                unless ($value =~ /^\s*$/) {
                    my $existing = $hash->get ('.value');
                    defined $existing and ($value .= $existing);
                    $hash->set ('.value' => $value);
                }
            } else {
                # If there is more than one of a single tupe of child element,
                # That child element must become an array
                if ($hash->exists ($element)) {
                    my $existing = $hash->get ($element);
                    unless (ref $existing eq 'ARRAY') {
                        $hash->set ($element => [ $existing ]);
                    }
                    push @{$hash->get ($element)}, tidy (@{$value});
                } else {
                    $hash->set ($element => tidy (@{$value}));
                }
            }
        }
        # If the element only has a value, it can become a scalar
        if (scalar $hash->keys == 1 and $hash->exists ('.value')) {
            return $hash->get ('.value');
        }
        return $hash;
    }
    return tidy (@{@$data[1]});
}

# Writes a data structure to an XML file
sub write_xml {
    my ($hash, $file, $mode) = @_;
    $mode = '>' unless defined $mode;
    my $FH;
    if ($file ne '-') {
        unless (open $FH, $mode . ':utf8', $file) {
            print STDERR "Failed to open output file '$file': $!\n";
            return 0;
        }
        select $FH;
    }
    sub escape {
        my @r;
        for (@_) {
            my $str = ''. $_;
            $str =~ s/(['\\])/\\$1'/g;
            push @r, $str;
        }
        return @r;
    }
    sub open_tag {
        my ($indent, $tag, $attr) = @_;
        print $indent, "<", $tag;
        if (defined $attr) {
            my $iter = $attr->iterator;
            while (my ($key, $value) = $iter->()) {
                print " ", $key, '="', escape $value, '"';
            }
        }
        print ">";
    }
    sub write_element {
        my ($indent, $hash) = @_;
        for my $key ($hash->keys) {
            $key eq '.attr' && next;
            my $val = $hash->get ($key);
            $key eq '.value' && do {
                print $val, "\n";
                next;
            };
            for (ref $val) {
                /^ARRAY$/ && do {
                    for my $element (@$val) {
                        open_tag ($indent, $key, $element->get ('.attr'));
                        for (ref $element) {
                            /^Hash::Ordered$/ && do {
                                print "\n";
                                write_element ("  $indent", $element);
                                print $indent, "</", $key, ">\n";
                                last;
                            };
                            print $element, "</", $key, ">\n";
                        }
                    }
                    last;
                };
                /^Hash::Ordered$/ && do {
                    open_tag ($indent, $key, $val->get ('.attr'));
                    # If the element only has a value with attributes,
                    # it can be formatted on one line
                    if (scalar $val->keys == 2 and $val->exists ('.value')) {
                        print $val->get ('.value'), "</", $key, ">\n";
                    } else {
                        print "\n";
                        write_element ("  $indent", $val);
                        print $indent, "</", $key, ">\n";
                    }
                    last;
                };
                open_tag ($indent, $key);
                print $val;
                print "</", $key, ">\n";
            }
        }
    }
    write_element ("", $hash);
    if ($file ne '-') {
        select STDOUT;
        close $FH;
    }
    return 1;
}

1;