source: main/trunk/package-kits/scripts/gs-servlet.pl@ 29674

#!/usr/bin/env perl 

use strict;
use warnings;
use utf8;

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

use lib 'perllib';
use XML::Tidy;

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 exists $hash->{'.attr'}) {
                    for my $attr ($new->{'.attr'}) {
                        $hash->{'.attr'}->{$attr} = $new->{'.attr'}->{$attr};
                    }
                } elsif (exists $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 (exists $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 (exists $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 (exists $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 (exists $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 (exists $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]->();
}