source: main/trunk/package-kits/linux/files/servlet.pl@ 29667

#!/usr/bin/env perl 

use strict;
use warnings;
use utf8;

use XML::Parser;
use Data::Dumper;

# 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_servlets {
    my $file = shift;
    # The xml needs a root element, so we wrap it in one
    my $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;
        # If the element has attributes, add them to the hash
        my $attr = shift;
        if (scalar keys %$attr > 0) {
            $hash{'.attr'} = $attr;
        }
        # Read any child elements or text value
        while (@_) {
            my $element = shift;
            my $value   = shift;
            if ($element eq 0) {
                $value =~ /^\s*$/ || ($hash{'.value'} .= $value);
            } else {
                # If there is more than one of a single tupe of child element,
                # That child element must become an array
                if (defined $hash{$element}) {
                    unless (ref $hash{$element} eq 'ARRAY') {
                        $hash{$element} = [ $hash{$element} ];
                    }
                    push @{$hash{$element}}, tidy (@{$value});
                } else {
                    $hash{$element} = tidy (@{$value});
                }
            }
        }
        # If the element only has a value, it can become a scalar
        if (scalar keys %hash == 1 and defined $hash{'.value'}) {
            return $hash{'.value'};
        }
        return \%hash;
    }
    return tidy (@{@$data[1]});
}

# Writes a data structure to an XML file
sub write_servlets {
    my ($hash, $file) = @_;
    my $OUT;
    if ($file ne '-') {
        open $OUT, '>', $file;
        select $OUT;
    }
    sub open_tag {
        my ($indent, $tag, $attr) = @_;
        print $indent, "<", $tag;
        if (defined $attr) {
            for my $key (sort keys %$attr) {
                print " ", $key, '="', $attr->{$key}, '"';
            }
        }
        print ">";
    }
    sub write_xml {
        my ($indent, $hash) = @_;
        for my $key (sort keys %$hash) {
            $key eq '.attr' && next;
            my $val = $hash->{$key};
            $key eq '.value' && do {
                print $val, "\n";
                next;
            };
            for (ref $val) {
                /^ARRAY$/ && do {
                    for my $element (@$val) {
                        open_tag ($indent, $key, $element->{'.attr'});
                        for (ref $element) {
                            /^HASH$/ && do {
                                print "\n";
                                write_xml ("  $indent", $element);
                                print $indent, "</", $key, ">\n";
                                last;
                            };
                            print $element, "</", $key, ">\n";
                        }
                    }
                    last;
                };
                /^HASH$/ && do {
                    open_tag ($indent, $key, $val->{'.attr'});
                    # If the element only has a value with attributes,
                    # it can be formatted on one line
                    if (scalar keys %$val == 2 and defined $val->{'.value'}) {
                        print $val->{'.value'}, "</", $key, ">\n";
                    } else {
                        print "\n";
                        write_xml ("  $indent", $val);
                        print $indent, "</", $key, ">\n";
                    }
                    last;
                };
                open_tag ($indent, $key);
                print $val;
                print "</", $key, ">\n";
            }
        }
    }
    write_xml ("", $hash);
    if (defined $OUT) {
        close $OUT;
    }
    select STDOUT;
}
# The code above is for generic XML read/writing
# The code below is specific to Greenstone's servlets.xml

my $hash;
# Hackish non-interactive CLI parser
while (@ARGV) {
    for (shift) {
        /^read$/i && do {
            $hash = read_servlets (shift);
            last;
        };
        /^write$/i && do {
            write_servlets ($hash, shift);
            last;
        };
        /^debug$/i && do {
            print Dumper $hash;
            last;
        };
        /^count$/i && do {
            my $servlets = $hash->{servlet};
            my $count = 1;
            if (ref $servlets eq 'ARRAY') {
                $count = scalar @{$hash->{servlet}};
            }
            print "Found ", $count, " servlets\n";
            last;
        };
        /^list$/i && do {
            print "Servlets:\n";
            my $servlets = $hash->{servlet};
            if (ref $servlets eq 'ARRAY') {
                for my $servlet (@{$hash->{servlet}}) {
                    print "  ", $servlet->{'servlet-name'}, "\n";
                }
            } else {
                print "  ", $servlets->{'servlet-name'}, "\n";
            }
            last;
        };
    }
}