root/main/trunk/package-kits/scripts/gs-servlet.pl @ 29673

Revision 29673, 6.2 KB (checked in by jts21, 5 years ago)

Moved servlet XML handling code to a module

  • Property svn:executable set to *
Line 
1#!/usr/bin/env perl
2
3use strict;
4use warnings;
5use utf8;
6
7use Data::Dumper;
8use POSIX 'isatty';
9
10use lib 'perllib';
11use XML::Tidy;
12
13my $hash;
14my %commands;
15# Command structure:
16# key: Case-insensitive name of the command
17# val: Array of info about the command
18#      [0]: Description of the command
19#      [1]: Function that is run for the command
20#      [2]: Number of arguments of the command (if any)
21#      [3]: True if the command has a variable number of args
22%commands = (
23    help => [
24        'Prints help about the available commands',
25        sub {
26            for my $cmd (sort keys %commands) {
27                printf "%-10s %s\n", $cmd, $commands{$cmd}[0];
28            }
29        },
30    ],
31    clear => [
32        'Clears the internal state',
33        sub {
34            undef $hash;
35            $hash = {};
36        }
37    ],
38    read => [
39        "Parses XML from a file into the internal state\n  input_file (- for STDIN)",
40        sub {
41            my $file = shift @ARGV;
42            my $new;
43            if ($file eq '-') {
44                if (isatty *STDIN) {
45                    print STDERR "Reading XML from STDIN. Press ^D to end\n";
46                }
47                $new = read_xml *STDIN;
48            } else {
49                open FH, '<', $file;
50                $new = read_xml *FH;
51                close FH;
52            }
53            # Append the new data to the current data
54            for my $key (keys %$new) {
55                if ($key eq '.attr' and defined $hash->{'.attr'}) {
56                    for my $attr ($new->{'.attr'}) {
57                        $hash->{'.attr'}->{$attr} = $new->{'.attr'}->{$attr};
58                    }
59                } elsif (defined $hash->{$key}) {
60                    if (ref $hash->{$key} ne 'ARRAY') {
61                        $hash->{$key} = [ $hash->{$key} ];
62                    }
63                    push @{$hash->{$key}},
64                        (ref $new->{$key} eq 'ARRAY' ? @{$new->{$key}} : $new->{$key});
65                } else {
66                    $hash->{$key} = $new->{$key};
67                }
68            }
69        },
70        1,
71    ],
72    write => [
73        "Writes the current internal state as XML to a file\n  output_file (- for STDOUT)",
74        sub {
75            my $file = shift @ARGV;
76            if ($file eq '-') {
77                write_xml $hash, *STDOUT;
78            } else {
79                open FH, '>', $file;
80                write_xml $hash, *FH;
81                close FH;
82            }
83        },
84        1,
85    ],
86    debug => [
87        'Dumps the current internal state to stdout',
88        sub {
89            print Dumper $hash;
90        },
91    ],
92    count => [
93        'Returns the number of servlets in the current internal state',
94        sub {
95            my $count = 0;
96            if (defined $hash->{servlet}) {
97                $count = 1;
98                my $servlets = $hash->{servlet};
99                if (ref $servlets eq 'ARRAY') {
100                    $count = scalar @{$hash->{servlet}};
101                }
102            }
103            print $count, "\n";
104        },
105    ],
106    list => [
107        'Lists the servlets in the current internal state',
108        sub {
109            if (defined $hash->{servlet}) {
110                my $servlets = $hash->{servlet};
111                if (ref $servlets eq 'ARRAY') {
112                    for my $servlet (@{$hash->{servlet}}) {
113                        print $servlet->{'servlet-name'}, "\n";
114                    }
115                } else {
116                    print $servlets->{'servlet-name'}, "\n";
117                }
118            } else {
119                print STDERR "No servlets found. Was valid XML provided?\n";
120            }
121        },
122    ],
123    remove => [
124        'Removes a servlet from the current internal state',
125        sub {
126            my $name = shift @ARGV;
127            if (defined $hash->{servlet}) {
128                my $servlets = $hash->{servlet};
129                if (ref $servlets eq 'ARRAY') {
130                    my @array = grep { $_->{'servlet-name'} ne $name } @$servlets;
131                    $hash->{servlet} = \@array;
132                } elsif ($servlets->{'servlet-name'} eq $name) {
133                    delete $hash->{servlet};
134                }
135            }
136        },
137        1,
138    ],
139    add => [
140        "Adds a new servlet to the current internal state\n  name description class [param=value param2=value...] ;",
141        sub {
142            my %servlet = (
143                'servlet-name' => shift @ARGV,
144                'description'  => shift @ARGV,
145                'servlet-class'=> shift @ARGV,
146                'init-param'   => [],
147            );
148            while (@ARGV) {
149                my $param = shift @ARGV;
150                $param eq ';' and last;
151                my ($key, $value) = split '=', $param, 2;
152                (defined $key and defined $value) or die "Expected params in form 'param=value'\n";
153                push @{$servlet{'init-param'}}, {
154                    'param-name'  => $key,
155                    'param-value' => $value,
156                };
157            }
158            if (defined $hash->{servlet}) {
159                unless (ref $hash->{servlet} eq 'ARRAY') {
160                    $hash->{servlet} = [ $hash->{servlet} ];
161                }
162                push @{$hash->{servlet}}, \%servlet;
163            } else {
164                $hash->{servlet} = \%servlet;
165            }
166        },
167        3,
168        1,
169    ],
170);
171
172# Check that all given commands are valid
173my $argc = 0;
174my $varargs = 0;
175for my $cmd (@ARGV) {
176    if ($varargs and $cmd eq ';') {
177        $varargs = 0;
178    } elsif ($argc > 0) {
179        # skip arguments to a previous command
180        $argc --;
181    } elsif ($varargs) {
182    } elsif (defined $commands{$cmd}) {
183        # get the argument count of a valid command
184        $argc = @{$commands{$cmd}}[2];
185        defined $argc or ($argc = 0);
186        $varargs = @{$commands{$cmd}}[3];
187    } else {
188        # invalid command
189        print STDERR "Valid commands are:\n";
190        @{$commands{help}}[1]->();
191        die "Invalid command '" . $cmd . "'\n";
192    }
193}
194$argc != 0 and die "Expected $argc more argument" . ($argc != 1 ? "s" : "") . "\n";
195$varargs and die "Unclosed vararg command. Add an argument ';' to close the varargs\n";
196
197# Run the commands
198while (@ARGV) {
199    @{$commands{lc shift}}[1]->();
200}
Note: See TracBrowser for help on using the browser.