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

#!/usr/bin/env perl 

use strict;
use warnings;
use utf8;

use XML::Parser;
use Data::Dumper;
use POSIX 'isatty';

# 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 $FH = shift;
    local $/ = undef;
    my $xml = <$FH>;
    # The xml needs a root element, so we wrap it in one
    $xml='<__root__>' . $xml . '</__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_xml {
    my ($hash, $FH) = @_;
    select $FH;
    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_element {
        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_element ("  $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_element ("  $indent", $val);
                        print $indent, "</", $key, ">\n";
                    }
                    last;
                };
                open_tag ($indent, $key);
                print $val;
                print "</", $key, ">\n";
            }
        }
    }
    write_element ("", $hash);
    select STDOUT;
}

my $hash;
my %commands;
# Command structure:
# key: Case-insensitive name of the command
# val: Array of info about the command
#      [0]: Description of the command
#      [1]: Function that is run for the command
#      [2]: Number of arguments of the command (if any)
#      [3]: True if the command has a variable number of args
%commands = (
    help => [
        'Prints help about the available commands',
        sub {
            for my $cmd (sort keys %commands) {
                printf "%-10s %s\n", $cmd, $commands{$cmd}[0];
            }
        },
    ],
    clear => [
        'Clears the internal state',
        sub {
            undef $hash;
            $hash = {};
        }
    ],
    read => [
        "Parses XML from a file into the internal state\n  input_file (- for STDIN)",
        sub {
            my $file = shift @ARGV;
            my $new;
            if ($file eq '-') {
                if (isatty *STDIN) {
                    print STDERR "Reading XML from STDIN. Press ^D to end\n";
                }
                $new = read_xml *STDIN;
            } else {
                open FH, '<', $file;
                $new = read_xml *FH;
                close FH;
            }
            # Append the new data to the current data
            for my $key (keys %$new) {
                if ($key eq '.attr' and defined $hash->{'.attr'}) {
                    for my $attr ($new->{'.attr'}) {
                        $hash->{'.attr'}->{$attr} = $new->{'.attr'}->{$attr};
                    }
                } elsif (defined $hash->{$key}) {
                    if (ref $hash->{$key} ne 'ARRAY') {
                        $hash->{$key} = [ $hash->{$key} ];
                    }
                    push @{$hash->{$key}},
                        (ref $new->{$key} eq 'ARRAY' ? @{$new->{$key}} : $new->{$key});
                } else {
                    $hash->{$key} = $new->{$key};
                }
            }
        },
        1,
    ],
    write => [
        "Writes the current internal state as XML to a file\n  output_file (- for STDOUT)",
        sub {
            my $file = shift @ARGV;
            if ($file eq '-') {
                write_xml $hash, *STDOUT;
            } else {
                open FH, '>', $file;
                write_xml $hash, *FH;
                close FH;
            }
        },
        1,
    ],
    debug => [
        'Dumps the current internal state to stdout',
        sub {
            print Dumper $hash;
        },
    ],
    count => [
        'Returns the number of servlets in the current internal state',
        sub {
            my $count = 0;
            if (defined $hash->{servlet}) {
                $count = 1;
                my $servlets = $hash->{servlet};
                if (ref $servlets eq 'ARRAY') {
                    $count = scalar @{$hash->{servlet}};
                }
            }
            print $count, "\n";
        },
    ],
    list => [
        'Lists the servlets in the current internal state',
        sub {
            if (defined $hash->{servlet}) {
                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";
                }
            } else {
                print STDERR "No servlets found. Was valid XML provided?\n";
            }
        },
    ],
    remove => [
        'Removes a servlet from the current internal state',
        sub {
            my $name = shift @ARGV;
            if (defined $hash->{servlet}) {
                my $servlets = $hash->{servlet};
                if (ref $servlets eq 'ARRAY') {
                    my @array = grep { $_->{'servlet-name'} ne $name } @$servlets;
                    $hash->{servlet} = \@array;
                } elsif ($servlets->{'servlet-name'} eq $name) {
                    delete $hash->{servlet};
                }
            }
        },
        1,
    ],
    add => [
        "Adds a new servlet to the current internal state\n  name description class [param=value param2=value...] ;",
        sub {
            my %servlet = (
                'servlet-name' => shift @ARGV,
                'description'  => shift @ARGV,
                'servlet-class'=> shift @ARGV,
                'init-param'   => [],
            );
            while (@ARGV) {
                my $param = shift @ARGV;
                $param eq ';' and last;
                my ($key, $value) = split '=', $param, 2;
                (defined $key and defined $value) or die "Expected params in form 'param=value'\n";
                push @{$servlet{'init-param'}}, {
                    'param-name'  => $key,
                    'param-value' => $value,
                };
            }
            if (defined $hash->{servlet}) {
                unless (ref $hash->{servlet} eq 'ARRAY') {
                    $hash->{servlet} = [ $hash->{servlet} ];
                }
                push @{$hash->{servlet}}, \%servlet;
            } else {
                $hash->{servlet} = \%servlet;
            }
        },
        3,
        1,
    ],
);

# Check that all given commands are valid
my $argc = 0;
my $varargs = 0;
for my $cmd (@ARGV) {
    if ($varargs and $cmd eq ';') {
        $varargs = 0;
    } elsif ($argc > 0) {
        # skip arguments to a previous command
        $argc --;
    } elsif ($varargs) {
    } elsif (defined $commands{$cmd}) {
        # get the argument count of a valid command
        $argc = @{$commands{$cmd}}[2];
        defined $argc or ($argc = 0);
        $varargs = @{$commands{$cmd}}[3];
    } else {
        # invalid command
        print STDERR "Valid commands are:\n";
        @{$commands{help}}[1]->();
        die "Invalid command '" . $cmd . "'\n";
    }
}
$argc != 0 and die "Expected $argc more argument" . ($argc != 1 ? "s" : "") . "\n";
$varargs and die "Unclosed vararg command. Add an argument ';' to close the varargs\n";

# Run the commands
while (@ARGV) {
    @{$commands{lc shift}}[1]->();
}