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

Revision 29672, 10.9 KB (checked in by jts21, 5 years ago)

Added command to add a servlet. Config is given as commandline options. Variable numbers of arguments (such as init-params) are terminated with \; (similar to find -exec)

  • Property svn:executable set to *
Line 
1#!/usr/bin/env perl
2
3use strict;
4use warnings;
5use utf8;
6
7use XML::Parser;
8use Data::Dumper;
9use POSIX 'isatty';
10
11# Reads the servlets partial XML file using XML::Parser,
12# Then converts the obtained data structure to a more readable one
13# Example conversion:
14=xml
15<servlet>
16  <servlet-name>library</servlet-name>
17  <description attribute="example">The standard gsdl3 library program</description>
18  <servlet-class>org.greenstone.gsdl3.LibraryServlet</servlet-class>
19  <init-param>
20    <param-name>library_name</param-name>
21    <param-value>library</param-value>
22  </init-param>
23  <init-param>
24    <param-name>site_name</param-name>
25    <param-value>localsite</param-value>
26  </init-param>
27</servlet>
28=cut
29=data_structure
30{
31    'servlet' => {
32        'servlet-class' => 'org.greenstone.gsdl3.LibraryServlet',
33        'servlet-name' => 'library',
34        'description' => {
35            '.value' => 'The standard gsdl3 library program',
36            '.attr' => {
37                'attribute' => 'example'
38            }
39        },
40        'init-param' => [
41            {
42                'param-value' => 'library',
43                'param-name' => 'library_name'
44            },
45            {
46                'param-name' => 'site_name',
47                'param-value' => 'localsite'
48            }
49        ]
50    }
51}
52=cut
53sub read_xml {
54    my $FH = shift;
55    local $/ = undef;
56    my $xml = <$FH>;
57    # The xml needs a root element, so we wrap it in one
58    $xml='<__root__>' . $xml . '</__root__>';
59    # Parse the data using XML::Parser
60    my $data = new XML::Parser (Style => 'Tree')->parse ($xml);
61
62    sub tidy {
63        my %hash;
64        # If the element has attributes, add them to the hash
65        my $attr = shift;
66        if (scalar keys %$attr > 0) {
67            $hash{'.attr'} = $attr;
68        }
69        # Read any child elements or text value
70        while (@_) {
71            my $element = shift;
72            my $value   = shift;
73            if ($element eq 0) {
74                $value =~ /^\s*$/ || ($hash{'.value'} .= $value);
75            } else {
76                # If there is more than one of a single tupe of child element,
77                # That child element must become an array
78                if (defined $hash{$element}) {
79                    unless (ref $hash{$element} eq 'ARRAY') {
80                        $hash{$element} = [ $hash{$element} ];
81                    }
82                    push @{$hash{$element}}, tidy (@{$value});
83                } else {
84                    $hash{$element} = tidy (@{$value});
85                }
86            }
87        }
88        # If the element only has a value, it can become a scalar
89        if (scalar keys %hash == 1 and defined $hash{'.value'}) {
90            return $hash{'.value'};
91        }
92        return \%hash;
93    }
94    return tidy (@{@$data[1]});
95}
96
97# Writes a data structure to an XML file
98sub write_xml {
99    my ($hash, $FH) = @_;
100    select $FH;
101    sub open_tag {
102        my ($indent, $tag, $attr) = @_;
103        print $indent, "<", $tag;
104        if (defined $attr) {
105            for my $key (sort keys %$attr) {
106                print " ", $key, '="', $attr->{$key}, '"';
107            }
108        }
109        print ">";
110    }
111    sub write_element {
112        my ($indent, $hash) = @_;
113        for my $key (sort keys %$hash) {
114            $key eq '.attr' && next;
115            my $val = $hash->{$key};
116            $key eq '.value' && do {
117                print $val, "\n";
118                next;
119            };
120            for (ref $val) {
121                /^ARRAY$/ && do {
122                    for my $element (@$val) {
123                        open_tag ($indent, $key, $element->{'.attr'});
124                        for (ref $element) {
125                            /^HASH$/ && do {
126                                print "\n";
127                                write_element ("  $indent", $element);
128                                print $indent, "</", $key, ">\n";
129                                last;
130                            };
131                            print $element, "</", $key, ">\n";
132                        }
133                    }
134                    last;
135                };
136                /^HASH$/ && do {
137                    open_tag ($indent, $key, $val->{'.attr'});
138                    # If the element only has a value with attributes,
139                    # it can be formatted on one line
140                    if (scalar keys %$val == 2 and defined $val->{'.value'}) {
141                        print $val->{'.value'}, "</", $key, ">\n";
142                    } else {
143                        print "\n";
144                        write_element ("  $indent", $val);
145                        print $indent, "</", $key, ">\n";
146                    }
147                    last;
148                };
149                open_tag ($indent, $key);
150                print $val;
151                print "</", $key, ">\n";
152            }
153        }
154    }
155    write_element ("", $hash);
156    select STDOUT;
157}
158
159my $hash;
160my %commands;
161# Command structure:
162# key: Case-insensitive name of the command
163# val: Array of info about the command
164#      [0]: Description of the command
165#      [1]: Function that is run for the command
166#      [2]: Number of arguments of the command (if any)
167#      [3]: True if the command has a variable number of args
168%commands = (
169    help => [
170        'Prints help about the available commands',
171        sub {
172            for my $cmd (sort keys %commands) {
173                printf "%-10s %s\n", $cmd, $commands{$cmd}[0];
174            }
175        },
176    ],
177    clear => [
178        'Clears the internal state',
179        sub {
180            undef $hash;
181            $hash = {};
182        }
183    ],
184    read => [
185        "Parses XML from a file into the internal state\n  input_file (- for STDIN)",
186        sub {
187            my $file = shift @ARGV;
188            my $new;
189            if ($file eq '-') {
190                if (isatty *STDIN) {
191                    print STDERR "Reading XML from STDIN. Press ^D to end\n";
192                }
193                $new = read_xml *STDIN;
194            } else {
195                open FH, '<', $file;
196                $new = read_xml *FH;
197                close FH;
198            }
199            # Append the new data to the current data
200            for my $key (keys %$new) {
201                if ($key eq '.attr' and defined $hash->{'.attr'}) {
202                    for my $attr ($new->{'.attr'}) {
203                        $hash->{'.attr'}->{$attr} = $new->{'.attr'}->{$attr};
204                    }
205                } elsif (defined $hash->{$key}) {
206                    if (ref $hash->{$key} ne 'ARRAY') {
207                        $hash->{$key} = [ $hash->{$key} ];
208                    }
209                    push @{$hash->{$key}},
210                        (ref $new->{$key} eq 'ARRAY' ? @{$new->{$key}} : $new->{$key});
211                } else {
212                    $hash->{$key} = $new->{$key};
213                }
214            }
215        },
216        1,
217    ],
218    write => [
219        "Writes the current internal state as XML to a file\n  output_file (- for STDOUT)",
220        sub {
221            my $file = shift @ARGV;
222            if ($file eq '-') {
223                write_xml $hash, *STDOUT;
224            } else {
225                open FH, '>', $file;
226                write_xml $hash, *FH;
227                close FH;
228            }
229        },
230        1,
231    ],
232    debug => [
233        'Dumps the current internal state to stdout',
234        sub {
235            print Dumper $hash;
236        },
237    ],
238    count => [
239        'Returns the number of servlets in the current internal state',
240        sub {
241            my $count = 0;
242            if (defined $hash->{servlet}) {
243                $count = 1;
244                my $servlets = $hash->{servlet};
245                if (ref $servlets eq 'ARRAY') {
246                    $count = scalar @{$hash->{servlet}};
247                }
248            }
249            print $count, "\n";
250        },
251    ],
252    list => [
253        'Lists the servlets in the current internal state',
254        sub {
255            if (defined $hash->{servlet}) {
256                my $servlets = $hash->{servlet};
257                if (ref $servlets eq 'ARRAY') {
258                    for my $servlet (@{$hash->{servlet}}) {
259                        print $servlet->{'servlet-name'}, "\n";
260                    }
261                } else {
262                    print $servlets->{'servlet-name'}, "\n";
263                }
264            } else {
265                print STDERR "No servlets found. Was valid XML provided?\n";
266            }
267        },
268    ],
269    remove => [
270        'Removes a servlet from the current internal state',
271        sub {
272            my $name = shift @ARGV;
273            if (defined $hash->{servlet}) {
274                my $servlets = $hash->{servlet};
275                if (ref $servlets eq 'ARRAY') {
276                    my @array = grep { $_->{'servlet-name'} ne $name } @$servlets;
277                    $hash->{servlet} = \@array;
278                } elsif ($servlets->{'servlet-name'} eq $name) {
279                    delete $hash->{servlet};
280                }
281            }
282        },
283        1,
284    ],
285    add => [
286        "Adds a new servlet to the current internal state\n  name description class [param=value param2=value...] ;",
287        sub {
288            my %servlet = (
289                'servlet-name' => shift @ARGV,
290                'description'  => shift @ARGV,
291                'servlet-class'=> shift @ARGV,
292                'init-param'   => [],
293            );
294            while (@ARGV) {
295                my $param = shift @ARGV;
296                $param eq ';' and last;
297                my ($key, $value) = split '=', $param, 2;
298                (defined $key and defined $value) or die "Expected params in form 'param=value'\n";
299                push @{$servlet{'init-param'}}, {
300                    'param-name'  => $key,
301                    'param-value' => $value,
302                };
303            }
304            if (defined $hash->{servlet}) {
305                unless (ref $hash->{servlet} eq 'ARRAY') {
306                    $hash->{servlet} = [ $hash->{servlet} ];
307                }
308                push @{$hash->{servlet}}, \%servlet;
309            } else {
310                $hash->{servlet} = \%servlet;
311            }
312        },
313        3,
314        1,
315    ],
316);
317
318# Check that all given commands are valid
319my $argc = 0;
320my $varargs = 0;
321for my $cmd (@ARGV) {
322    if ($varargs and $cmd eq ';') {
323        $varargs = 0;
324    } elsif ($argc > 0) {
325        # skip arguments to a previous command
326        $argc --;
327    } elsif ($varargs) {
328    } elsif (defined $commands{$cmd}) {
329        # get the argument count of a valid command
330        $argc = @{$commands{$cmd}}[2];
331        defined $argc or ($argc = 0);
332        $varargs = @{$commands{$cmd}}[3];
333    } else {
334        # invalid command
335        print STDERR "Valid commands are:\n";
336        @{$commands{help}}[1]->();
337        die "Invalid command '" . $cmd . "'\n";
338    }
339}
340$argc != 0 and die "Expected $argc more argument" . ($argc != 1 ? "s" : "") . "\n";
341$varargs and die "Unclosed vararg command. Add an argument ';' to close the varargs\n";
342
343# Run the commands
344while (@ARGV) {
345    @{$commands{lc shift}}[1]->();
346}
Note: See TracBrowser for help on using the browser.