Index: in/trunk/package-kits/linux/files/servlet.pl
===================================================================
--- /main/trunk/package-kits/linux/files/servlet.pl (revision 29672)
+++ (revision )
@@ -1,346 +1,0 @@
-#!/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
-
- library
- The standard gsdl3 library program
- org.greenstone.gsdl3.LibraryServlet
-
- library_name
- library
-
-
- site_name
- localsite
-
-
-=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 . '';
- # 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]->();
-}
Index: /main/trunk/package-kits/scripts/gs-servlet.pl
===================================================================
--- /main/trunk/package-kits/scripts/gs-servlet.pl (revision 29673)
+++ /main/trunk/package-kits/scripts/gs-servlet.pl (revision 29673)
@@ -0,0 +1,200 @@
+#!/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 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]->();
+}
Index: /main/trunk/package-kits/scripts/perllib/XML/Tidy.pm
===================================================================
--- /main/trunk/package-kits/scripts/perllib/XML/Tidy.pm (revision 29673)
+++ /main/trunk/package-kits/scripts/perllib/XML/Tidy.pm (revision 29673)
@@ -0,0 +1,158 @@
+package XML::Tidy;
+
+use strict;
+use warnings;
+use utf8;
+use XML::Parser;
+use base 'Exporter';
+
+our $VERSION = 1.00;
+our @EXPORT = ( 'read_xml', 'write_xml' );
+
+# Reads the servlets partial XML file using XML::Parser,
+# Then converts the obtained data structure to a more readable one
+# Example conversion:
+=xml
+
+ library
+ The standard gsdl3 library program
+ org.greenstone.gsdl3.LibraryServlet
+
+ library_name
+ library
+
+
+ site_name
+ localsite
+
+
+=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 . '';
+ # 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;
+}