From 8c05b81d6860d8e0da4098cc6f59f630d7c53037 Mon Sep 17 00:00:00 2001
From: Adam Frisby
Date: Tue, 25 Mar 2008 16:29:54 +0000
Subject: * Committing Lulurun's Cgi/Perl implementation of the UGAI servers. *
I love you long time.
---
share/perl/README | 40 +
share/perl/asset.cgi | 43 +
share/perl/conf/httpd-vhosts.conf | 25 +
share/perl/conf/mod_perl-startup.pl | 34 +
share/perl/grid.cgi | 27 +
share/perl/inventory.cgi | 39 +
share/perl/lib/DBHandler.pm | 119 +
share/perl/lib/MyCGI.pm | 91 +
share/perl/lib/OpenSim/AssetServer.pm | 87 +
share/perl/lib/OpenSim/AssetServer/AssetManager.pm | 34 +
share/perl/lib/OpenSim/AssetServer/Config.pm | 24 +
share/perl/lib/OpenSim/Config.pm | 41 +
share/perl/lib/OpenSim/GridServer.pm | 208 ++
share/perl/lib/OpenSim/GridServer/Config.pm | 50 +
share/perl/lib/OpenSim/GridServer/GridManager.pm | 57 +
share/perl/lib/OpenSim/InventoryServer.pm | 249 ++
share/perl/lib/OpenSim/InventoryServer/Config.pm | 51 +
.../OpenSim/InventoryServer/InventoryManager.pm | 86 +
share/perl/lib/OpenSim/UserServer.pm | 239 ++
share/perl/lib/OpenSim/UserServer/Config.pm | 125 +
share/perl/lib/OpenSim/UserServer/UserManager.pm | 49 +
share/perl/lib/OpenSim/Utility.pm | 155 +
share/perl/lib/XML/RPC.pm | 217 ++
share/perl/lib/XML/Serializer.pm | 163 +
share/perl/lib/XML/Simple.pm | 3284 ++++++++++++++++++++
share/perl/lib/XML/TreePP.pm | 1228 ++++++++
share/perl/test/OpenSimTest.pm | 53 +
share/perl/test/OpenSimTest/AssetTester.pm | 17 +
share/perl/test/OpenSimTest/Config.pm | 53 +
share/perl/test/OpenSimTest/GridTester.pm | 62 +
share/perl/test/OpenSimTest/InventoryTester.pm | 116 +
share/perl/test/OpenSimTest/UserTester.pm | 53 +
share/perl/test/PerformanceTest.pl | 78 +
share/perl/test/SingleTest.pl | 21 +
share/perl/user.cgi | 28 +
35 files changed, 7246 insertions(+)
create mode 100644 share/perl/README
create mode 100644 share/perl/asset.cgi
create mode 100644 share/perl/conf/httpd-vhosts.conf
create mode 100644 share/perl/conf/mod_perl-startup.pl
create mode 100644 share/perl/grid.cgi
create mode 100644 share/perl/inventory.cgi
create mode 100644 share/perl/lib/DBHandler.pm
create mode 100644 share/perl/lib/MyCGI.pm
create mode 100644 share/perl/lib/OpenSim/AssetServer.pm
create mode 100644 share/perl/lib/OpenSim/AssetServer/AssetManager.pm
create mode 100644 share/perl/lib/OpenSim/AssetServer/Config.pm
create mode 100644 share/perl/lib/OpenSim/Config.pm
create mode 100644 share/perl/lib/OpenSim/GridServer.pm
create mode 100644 share/perl/lib/OpenSim/GridServer/Config.pm
create mode 100644 share/perl/lib/OpenSim/GridServer/GridManager.pm
create mode 100644 share/perl/lib/OpenSim/InventoryServer.pm
create mode 100644 share/perl/lib/OpenSim/InventoryServer/Config.pm
create mode 100644 share/perl/lib/OpenSim/InventoryServer/InventoryManager.pm
create mode 100644 share/perl/lib/OpenSim/UserServer.pm
create mode 100644 share/perl/lib/OpenSim/UserServer/Config.pm
create mode 100644 share/perl/lib/OpenSim/UserServer/UserManager.pm
create mode 100644 share/perl/lib/OpenSim/Utility.pm
create mode 100644 share/perl/lib/XML/RPC.pm
create mode 100644 share/perl/lib/XML/Serializer.pm
create mode 100644 share/perl/lib/XML/Simple.pm
create mode 100644 share/perl/lib/XML/TreePP.pm
create mode 100644 share/perl/test/OpenSimTest.pm
create mode 100644 share/perl/test/OpenSimTest/AssetTester.pm
create mode 100644 share/perl/test/OpenSimTest/Config.pm
create mode 100644 share/perl/test/OpenSimTest/GridTester.pm
create mode 100644 share/perl/test/OpenSimTest/InventoryTester.pm
create mode 100644 share/perl/test/OpenSimTest/UserTester.pm
create mode 100644 share/perl/test/PerformanceTest.pl
create mode 100644 share/perl/test/SingleTest.pl
create mode 100644 share/perl/user.cgi
(limited to 'share')
diff --git a/share/perl/README b/share/perl/README
new file mode 100644
index 0000000..28bd9bf
--- /dev/null
+++ b/share/perl/README
@@ -0,0 +1,40 @@
+INTRODUCTION
+
+This is a Opensim UGAI server compatible implementation.
+It is written in Perl, based on apache (CGI or mod_perl)
+Not all of the functions of UGAI server are implemented, but currently,
+it supports the whole user login process and most of the operations on
+inventory, asset.
+
+The main purpose of this implemetation is to improve UGAI server's
+* stability - That's what Apache was born to do
+* scability - You can use reliable technology such as load balancing,
+ clustering that have been used for years.
+
+IMPLEMENTATION
+
+"*.cgi" are the server programs, for example of user server:
+opensim -> http://127.0.0.1:8002
+here -> http://127.0.0.1/user.cgi
+
+"lib" includes library file (*.pm) used by cgis.
+"test" includes testcases. Instructions are included in "*.pl" files.
+
+INSTALLNATION & CONFIGURATION
+
+* additional perl packages (Fedora, Suse, CentOS rpms available)
+ DBI
+ DBD::mysql
+ Data::UUID
+
+* A sample apache configuration file is included in "conf"
+ http-vhost.conf
+ mod_perl-startup.pl
+
+* lib/OpenSim/Config.pm need to be configured to fit your environment.
+ Please follow the comment in that file.
+
+CONTACT
+
+lulurun@gmail.com
+
diff --git a/share/perl/asset.cgi b/share/perl/asset.cgi
new file mode 100644
index 0000000..318e06f
--- /dev/null
+++ b/share/perl/asset.cgi
@@ -0,0 +1,43 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Carp;
+use MyCGI;
+use OpenSim::Config;
+use OpenSim::Utility;
+use OpenSim::AssetServer;
+
+# !!
+# TODO: ERROR code
+#
+my $param = &MyCGI::getParam();
+my $response = "";
+if ($ENV{REQUEST_METHOD} eq "POST") {
+ my $request = $param->{'POSTDATA'};
+ #&OpenSim::Utility::Log("asset", "request", $ENV{REQUEST_URI}, $request);
+ $response = &OpenSim::AssetServer::saveAsset($request);
+} else { # get
+ eval {
+ my $rest_param = &getRestParam();
+ #&OpenSim::Utility::Log("asset", "request", $ENV{REQUEST_URI});
+ my $rest_param_count = @$rest_param;
+ if ($rest_param_count < 2) {
+ Carp::croak($OpenSim::Config::SYS_MSG{FATAL});
+ }
+ $response = &OpenSim::AssetServer::getAsset($rest_param->[$#$rest_param], $param);
+ };
+ if ($@) {
+ $response = "$@"; # TODO: better return message needed.
+ }
+}
+#&OpenSim::Utility::Log("asset", "response", $response);
+&MyCGI::outputXml("utf-8", $response);
+
+sub getRestParam {
+ my $uri = $ENV{REQUEST_URI} || Carp::croak($OpenSim::Config::SYS_MSG{FATAL});
+ my ($request_uri, undef) = split(/\?/, $uri);
+ $request_uri =~ s/\/$//;
+ my @param = split(/\//, $request_uri);
+ return \@param;
+}
+
diff --git a/share/perl/conf/httpd-vhosts.conf b/share/perl/conf/httpd-vhosts.conf
new file mode 100644
index 0000000..447150f
--- /dev/null
+++ b/share/perl/conf/httpd-vhosts.conf
@@ -0,0 +1,25 @@
+LoadModule perl_module modules/mod_perl.so
+PerlRequire "conf/mod_perl-startup.pl"
+
+NameVirtualHost *:80
+
+ ServerName opensim.lulu
+ ServerAdmin webmaster@opensim.lulu
+ DocumentRoot /home/lulu/temp/opensim
+ ErrorLog logs/opensim-error_log
+ CustomLog logs/opensim-access_log common
+
+
+ Options MultiViews All
+ AllowOverride None
+ Order allow,deny
+ Allow from all
+
+
+
+ SetHandler perl-script
+ PerlResponseHandler ModPerl::Registry
+ PerlOptions +ParseHeaders
+
+
+
diff --git a/share/perl/conf/mod_perl-startup.pl b/share/perl/conf/mod_perl-startup.pl
new file mode 100644
index 0000000..e8bdb2c
--- /dev/null
+++ b/share/perl/conf/mod_perl-startup.pl
@@ -0,0 +1,34 @@
+# Taken from http://perl.apache.org/docs/2.0/user/handlers/server.html#Startup_File
+
+if ( ! $ENV{MOD_PERL}) { die "GATEWAY_INTERFACE not Perl!"; }
+
+# !!! set this to your opensim's lib
+use lib qw(/home/lulu/temp/opensim/lib);
+
+# enable if the mod_perl 1.0 compatibility is needed
+# use Apache2::compat ();
+
+# preload all mp2 modules
+# use ModPerl::MethodLookup;
+# ModPerl::MethodLookup::preload_all_modules();
+
+use ModPerl::Util (); #for CORE::GLOBAL::exit
+
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil ();
+
+use Apache2::ServerRec ();
+use Apache2::ServerUtil ();
+use Apache2::Connection ();
+use Apache2::Log ();
+
+use APR::Table ();
+
+use ModPerl::Registry ();
+
+use Apache2::Const -compile => ':common';
+use APR::Const -compile => ':common';
+
+
+1;
diff --git a/share/perl/grid.cgi b/share/perl/grid.cgi
new file mode 100644
index 0000000..cf1550f
--- /dev/null
+++ b/share/perl/grid.cgi
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Carp;
+use XML::RPC;
+use MyCGI;
+use OpenSim::Utility;
+use OpenSim::GridServer;
+
+my $param = &MyCGI::getParam();
+my $request = $param->{'POSTDATA'};
+#&OpenSim::Utility::Log("grid", "request", $request);
+my $xmlrpc = new XML::RPC();
+my $response = $xmlrpc->receive($request, \&XMLRPCHandler);
+#&OpenSim::Utility::Log("grid", "response", $response);
+&MyCGI::outputXml("utf-8", $response);
+
+sub XMLRPCHandler {
+ my ($methodname, @param) = @_;
+ my $handler_list = &OpenSim::GridServer::getHandlerList();
+ if (!$handler_list->{$methodname}) {
+ Carp::croak("?");
+ } else {
+ my $handler = $handler_list->{$methodname};
+ $handler->(@param);
+ }
+}
diff --git a/share/perl/inventory.cgi b/share/perl/inventory.cgi
new file mode 100644
index 0000000..0542436
--- /dev/null
+++ b/share/perl/inventory.cgi
@@ -0,0 +1,39 @@
+#!/usr/bin/perl -w
+
+use strict;
+use MyCGI;
+use OpenSim::Config;
+use OpenSim::InventoryServer;
+use Carp;
+
+my $request_uri = $ENV{REQUEST_URI} || Carp::croak($OpenSim::Config::SYS_MSG{FATAL});
+my $request_method = "";
+if ($request_uri =~ /([^\/]+)\/$/) {
+ $request_method = $1;
+} else {
+ &MyCGI::outputXml("utf-8", $OpenSim::Config::SYS_MSG{FATAL});
+}
+my $param = &MyCGI::getParam();
+my $post_data = $param->{'POSTDATA'};
+&OpenSim::Utility::Log("inv", "request", $request_uri, $post_data);
+my $response = "";
+eval {
+ $response = &handleRequest($request_method, $post_data);
+};
+if ($@) {
+ $response = "$@";
+}
+&OpenSim::Utility::Log("inv", "response", $response);
+&MyCGI::outputXml("utf-8", $response);
+
+sub handleRequest {
+ my ($methodname, $post_data) = @_;
+ my $handler_list = &OpenSim::InventoryServer::getHandlerList();
+ if (!$handler_list->{$methodname}) {
+ Carp::croak("unknown method name");
+ } else {
+ my $handler = $handler_list->{$methodname};
+ return $handler->($post_data);
+ }
+}
+
diff --git a/share/perl/lib/DBHandler.pm b/share/perl/lib/DBHandler.pm
new file mode 100644
index 0000000..1435ba2
--- /dev/null
+++ b/share/perl/lib/DBHandler.pm
@@ -0,0 +1,119 @@
+use strict;
+use DBI;
+use Carp;
+
+package DBHandler;
+
+#our $dbh = undef;
+use vars qw ($DB_CONNECTION);
+
+sub getConnection {
+ my ($dsn, $user, $pass) = @_;
+ #return $DB_CONNECTION if ($DB_CONNECTION);
+ $DB_CONNECTION = DBI->connect($dsn, $user, $pass);
+ $DB_CONNECTION->{AutoCommit} = 1;
+ $DB_CONNECTION->{RaiseError} = 1;
+ return $DB_CONNECTION;
+}
+
+# #############
+# Simple statement
+package Statement;
+
+sub new {
+ my ( $this, $dbh, $sql, $is_trans ) = @_;
+ # @@@ sql should be tested OK, so here just die
+ my $sth = $dbh->prepare($sql) || Carp::croak( $dbh->errstr );
+ my %fields = (
+ dbh => $dbh,
+ sql => $sql,
+ sth => $sth,
+ is_trans => $is_trans,
+ );
+ return bless \%fields, $this;
+}
+
+sub exec {
+ my ( $this, @param ) = @_;
+ my $dbh = $this->{dbh};
+ my $sth = $this->{sth};
+ my $sql = $this->{sql};
+
+ if ( !$sth->execute(@param) ) {
+ if ( $this->{is_trans} ) {
+ $dbh->rollback();
+ }
+ Carp::croak( $dbh->errstr );
+ }
+ my @ret = ();
+ if ( $sql =~ /^select/i ) {
+ # @@@ get result object
+ while ( my $res = $sth->fetchrow_hashref() ) {
+ push @ret, $res;
+ }
+ }
+ # @@@ $sth->finish();
+ return \@ret;
+}
+
+sub last_id {
+ my $this = shift;
+ my $dbh = $this->{dbh};
+ return $dbh->last_insert_id(undef, undef, undef, undef);
+}
+
+sub DESTROY {
+ my $this = shift;
+ my $sth = $this->{sth};
+ $sth->finish();
+}
+
+# #############
+# Transaction
+package Transaction;
+
+my $IS_TRANS = 1;
+
+sub new {
+ my ( $this, $dbh ) = @_;
+ # @@@ fatal error, just die
+ $dbh->begin_work() || Carp::croak( $dbh->errstr );
+ my %fields = (
+ dbh => $dbh,
+ Active => 1,
+ );
+ return bless \%fields, $this;
+}
+
+sub createStatement {
+ my ( $this, $sql) = @_;
+ # @@@ fatal error, just die
+ Carp::croak("transaction not begin") if ( !$this->{Active} );
+ my $dbh = $this->{dbh};
+ return new Statement($dbh, $sql, $IS_TRANS);
+}
+
+sub commit {
+ my $this = shift;
+ my $dbh = $this->{dbh};
+ if ( $this->{Active} && !$dbh->{AutoCommit} ) {
+ $dbh->commit || Carp::croak( $dbh->errstr );
+ }
+ $this->{Active} = 0;
+}
+
+sub rollback {
+ my $this = shift;
+ my $dbh = $this->{dbh};
+ if ( $this->{Active} && !$dbh->{AutoCommit} ) {
+ $dbh->rollback || Carp::croak( $dbh->errstr );
+ }
+ $this->{Active} = 0;
+}
+
+sub DESTROY {
+ my $this = shift;
+ $this->rollback;
+}
+
+1;
diff --git a/share/perl/lib/MyCGI.pm b/share/perl/lib/MyCGI.pm
new file mode 100644
index 0000000..1f232aa
--- /dev/null
+++ b/share/perl/lib/MyCGI.pm
@@ -0,0 +1,91 @@
+package MyCGI;
+
+use strict;
+use CGI;
+
+sub getParam {
+ my $cgi;
+ if ($ARGV[0]) {
+ $cgi = new CGI($ARGV[0]);
+ } else {
+ $cgi = new CGI;
+ }
+ my @param_names = $cgi->param();
+ my %param = ();
+ foreach (@param_names) {
+ $param{$_} = $cgi->param($_);
+ }
+ return \%param;
+}
+
+sub getCookie {
+ my $name = shift;
+ my $cookie_value = &CGI::cookie($name);
+ return &_parse($cookie_value);
+}
+
+sub outputHtml {
+ my ($charset, $html) = @_;
+ print &CGI::header(-charset => $charset);
+ print $html;
+}
+
+sub outputXml {
+ my ($charset, $xml) = @_;
+ print &CGI::header( -type => 'text/xml', -charset => $charset );
+ print $xml;
+}
+
+sub makeCookieValue {
+ my $param = shift;
+ my @data = ();
+ foreach(keys %$param) {
+ push(@data, $_ . "=" . $param->{$_});
+ }
+ return join("&", @data);
+}
+
+sub setCookie {
+ my $param = shift;
+ my $cookie = &CGI::cookie(
+ -name => $param->{name} || return,
+ -value => $param->{value},
+ -domain => $param->{domain},
+ -path => $param->{path},
+ -expires => $param->{expires},
+ );
+ return &CGI::header(-cookie => $cookie);
+}
+
+sub redirect {
+ my $dest = shift;
+ &CGI::redirect($dest);
+}
+
+sub urlEncode {
+ my $str = shift;
+ $str =~ s/([^\w ])/'%'.unpack('H2', $1)/eg;
+ $str =~ tr/ /+/;
+ return $str;
+}
+
+sub urlDecode {
+ my $str = shift;
+ $str =~ tr/+/ /;
+ $str =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2', $1)/eg;
+ return $str;
+}
+
+sub _parse {
+ my $value = shift;
+ my @pair = split(/&/, $value);
+ my %data = ();
+ foreach(@pair) {
+ my ($name, $value) = split(/=/, $_);
+ $data{$name} = $value;
+ }
+ return \%data;
+}
+
+1;
+
diff --git a/share/perl/lib/OpenSim/AssetServer.pm b/share/perl/lib/OpenSim/AssetServer.pm
new file mode 100644
index 0000000..6418166
--- /dev/null
+++ b/share/perl/lib/OpenSim/AssetServer.pm
@@ -0,0 +1,87 @@
+package OpenSim::AssetServer;
+
+use strict;
+use MIME::Base64;
+use XML::Simple;
+use OpenSim::Utility;
+use OpenSim::AssetServer::AssetManager;
+
+# !!
+# TODO: delete asset
+#
+
+sub getAsset {
+ my ($asset_id, $param) = @_;
+ # get asset
+ my $asset_id_string = &OpenSim::Utility::UUID2HEX($asset_id);
+ my $asset = &OpenSim::AssetServer::AssetManager::getAssetByUUID($asset_id_string);
+ $asset->{assetUUID} = $asset_id;
+ # make response
+ return &_asset_to_xml($asset);
+}
+
+sub saveAsset {
+ my $xml = shift;
+ my $asset = &_xml_to_asset($xml);
+ &OpenSim::AssetServer::AssetManager::saveAsset($asset);
+ return ""; # TODO: temporary solution of "success!"
+}
+
+# ##################
+# private functions
+sub _asset_to_xml {
+ my $asset = shift;
+ my $asset_data = &MIME::Base64::encode_base64($asset->{data});
+ return << "ASSET_XML";
+
+
+$asset_data
+
+
+ $asset->{assetUUID}
+
+ $asset->{assetType}
+ $asset->{invType}
+ $asset->{name}
+ $asset->{description}
+ $asset->{local}
+ $asset->{temporary}
+
+ASSET_XML
+}
+
+sub _xml_to_asset {
+ my $xml = shift;
+ my $xs = new XML::Simple();
+ my $obj = $xs->XMLin($xml);
+print STDERR $obj->{FullID}->{UUID} . "\n";
+ my %asset = (
+ "id" => &OpenSim::Utility::UUID2BIN($obj->{FullID}->{UUID}),
+ "name" => $obj->{Name},
+ "description" => $obj->{Description},
+ "assetType" => $obj->{Type},
+ "invType" => $obj->{InvType},
+ "local" => $obj->{Local},
+ "temporary" => $obj->{Temporary},
+ "data" => &MIME::Base64::decode_base64($obj->{Data}),
+ );
+ return \%asset;
+}
+
+1;
+
+__END__
+
+{
+ Data => "PFNjZW5lT2JqZWN0R3JvdXA+PFJvb3RQYXJ0PjxTY2VuZU9iamVjdFBhcnQgeG1sbnM6eHNpPSJodHRwOi8vd3d3LnczLm9yZy8yMDAxL1hNTFNjaGVtYS1pbnN0YW5jZSIgeG1sbnM6eHNkPSJodHRwOi8vd3d3LnczLm9yZy8yMDAxL1hNTFNjaGVtYSI+PExhc3RPd25lcklEPjxVVUlEPmI5Y2I1OGU4LWYzYzktNGFmNS1iZTQ3LTAyOTc2MmJhYTY4ZjwvVVVJRD48L0xhc3RPd25lcklEPjxPd25lcklEPjxVVUlEPmI5Y2I1OGU4LWYzYzktNGFmNS1iZTQ3LTAyOTc2MmJhYTY4ZjwvVVVJRD48L093bmVySUQ+PEdyb3VwSUQ+PFVVSUQ+MDAwMDAwMDAtMDAwMC0wMDAwLTAwMDAtMDAwMDAwMDAwMDAwPC9VVUlEPjwvR3JvdXBJRD48T3duZXJzaGlwQ29zdD4wPC9Pd25lcnNoaXBDb3N0PjxPYmplY3RTYWxlVHlwZT4wPC9PYmplY3RTYWxlVHlwZT48U2FsZVByaWNlPjA8L1NhbGVQcmljZT48Q2F0ZWdvcnk+MDwvQ2F0ZWdvcnk+PENyZWF0aW9uRGF0ZT4xMTk4NjQ5MjA5PC9DcmVhdGlvbkRhdGU+PFBhcmVudElEPjA8L1BhcmVudElEPjxPd25lck1hc2s+NTI2MDUzNjkyPC9Pd25lck1hc2s+PE5leHRPd25lck1hc2s+MjU3NDg3MTMyPC9OZXh0T3duZXJNYXNrPjxHcm91cE1hc2s+MDwvR3JvdXBNYXNrPjxFdmVyeW9uZU1hc2s+MDwvRXZlcnlvbmVNYXNrPjxCYXNlTWFzaz4yMTQ3NDgzNjQ3PC9CYXNlTWFzaz48Q3JlYXRvcklEPjxVVUlEPmI5Y2I1OGU4LWYzYzktNGFmNS1iZTQ3LTAyOTc2MmJhYTY4ZjwvVVVJRD48L0NyZWF0b3JJRD48VVVJRD48VVVJRD5hMGY3NmQzYi02MTlkLTRjNjktODVmOS0zNzhjMDExZDg2NzI8L1VVSUQ+PC9VVUlEPjxMb2NhbElEPjcwMjAwMTwvTG9jYWxJRD48TmFtZT5QcmltaXRpdmU8L05hbWU+PE9iamVjdEZsYWdzPjY1NjY2PC9PYmplY3RGbGFncz48TWF0ZXJpYWw+MDwvTWF0ZXJpYWw+PFJlZ2lvbkhhbmRsZT4xMDk5NTExNjI4MDMyMDAwPC9SZWdpb25IYW5kbGU+PEdyb3VwUG9zaXRpb24+PFg+MTMwLjA5OTQ8L1g+PFk+MTI4LjcxNTQ8L1k+PFo+MjEuMzM1NTI8L1o+PC9Hcm91cFBvc2l0aW9uPjxPZmZzZXRQb3NpdGlvbj48WD4wPC9YPjxZPjA8L1k+PFo+MDwvWj48L09mZnNldFBvc2l0aW9uPjxSb3RhdGlvbk9mZnNldD48WD4wPC9YPjxZPjA8L1k+PFo+MDwvWj48Vz4xPC9XPjwvUm90YXRpb25PZmZzZXQ+PFZlbG9jaXR5PjxYPjA8L1g+PFk+MDwvWT48Wj4wPC9aPjwvVmVsb2NpdHk+PFJvdGF0aW9uYWxWZWxvY2l0eT48WD4wPC9YPjxZPjA8L1k+PFo+MDwvWj48L1JvdGF0aW9uYWxWZWxvY2l0eT48QW5ndWxhclZlbG9jaXR5PjxYPjA8L1g+PFk+MDwvWT48Wj4wPC9aPjwvQW5ndWxhclZlbG9jaXR5PjxBY2NlbGVyYXRpb24+PFg+MDwvWD48WT4wPC9ZPjxaPjA8L1o+PC9BY2NlbGVyYXRpb24+PERlc2NyaXB0aW9uIC8+PENvbG9yIC8+PFRleHQgLz48U2l0TmFtZSAvPjxUb3VjaE5hbWUgLz48TGlua051bT4wPC9MaW5rTnVtPjxDbGlja0FjdGlvbj4wPC9DbGlja0FjdGlvbj48U2hhcGU+PFN0YXRlPjA8L1N0YXRlPjxQQ29kZT45PC9QQ29kZT48UGF0aEJlZ2luPjA8L1BhdGhCZWdpbj48UGF0aEVuZD4wPC9QYXRoRW5kPjxQYXRoU2NhbGVYPjIwMDwvUGF0aFNjYWxlWD48UGF0aFNjYWxlWT4yMDA8L1BhdGhTY2FsZVk+PFBhdGhTaGVhclg+MDwvUGF0aFNoZWFyWD48UGF0aFNoZWFyWT4wPC9QYXRoU2hlYXJZPjxQYXRoU2tldz4wPC9QYXRoU2tldz48UHJvZmlsZUJlZ2luPjA8L1Byb2ZpbGVCZWdpbj48UHJvZmlsZUVuZD4wPC9Qcm9maWxlRW5kPjxTY2FsZT48WD4wLjU8L1g+PFk+MC41PC9ZPjxaPjAuNTwvWj48L1NjYWxlPjxQYXRoQ3VydmU+MTY8L1BhdGhDdXJ2ZT48UHJvZmlsZUN1cnZlPjA8L1Byb2ZpbGVDdXJ2ZT48UHJvZmlsZUhvbGxvdz4wPC9Qcm9maWxlSG9sbG93PjxQYXRoUmFkaXVzT2Zmc2V0PjA8L1BhdGhSYWRpdXNPZmZzZXQ+PFBhdGhSZXZvbHV0aW9ucz4wPC9QYXRoUmV2b2x1dGlvbnM+PFBhdGhUYXBlclg+MDwvUGF0aFRhcGVyWD48UGF0aFRhcGVyWT4wPC9QYXRoVGFwZXJZPjxQYXRoVHdpc3Q+MDwvUGF0aFR3aXN0PjxQYXRoVHdpc3RCZWdpbj4wPC9QYXRoVHdpc3RCZWdpbj48VGV4dHVyZUVudHJ5PkFBQUFBQUFBQUFDWm1RQUFBQUFBQlFBQUFBQUFBQUFBZ0Q4QUFBQ0FQd0FBQUFBQUFBQUFBQUFBQUFBPTwvVGV4dHVyZUVudHJ5PjxFeHRyYVBhcmFtcz5BQT09PC9FeHRyYVBhcmFtcz48UHJvZmlsZVNoYXBlPkNpcmNsZTwvUHJvZmlsZVNoYXBlPjwvU2hhcGU+PFNjYWxlPjxYPjAuNTwvWD48WT4wLjU8L1k+PFo+MC41PC9aPjwvU2NhbGU+PFVwZGF0ZUZsYWc+MDwvVXBkYXRlRmxhZz48L1NjZW5lT2JqZWN0UGFydD48L1Jvb3RQYXJ0PjxPdGhlclBhcnRzIC8+PC9TY2VuZU9iamVjdEdyb3VwPgA=",
+ Description => {},
+ FullID => { UUID => "feb7e249-e462-499f-a881-553b9829539a" },
+ InvType => 6,
+ Local => "false",
+ Name => "Primitive",
+ Temporary => "false",
+ Type => 6,
+ "xmlns:xsd" => "http://www.w3.org/2001/XMLSchema",
+ "xmlns:xsi" => "http://www.w3.org/2001/XMLSchema-instance",
+}
+
diff --git a/share/perl/lib/OpenSim/AssetServer/AssetManager.pm b/share/perl/lib/OpenSim/AssetServer/AssetManager.pm
new file mode 100644
index 0000000..f36ab1a
--- /dev/null
+++ b/share/perl/lib/OpenSim/AssetServer/AssetManager.pm
@@ -0,0 +1,34 @@
+package OpenSim::AssetServer::AssetManager;
+
+use strict;
+use Carp;
+use OpenSim::Utility;
+use OpenSim::AssetServer::Config;
+
+
+sub getAssetByUUID {
+ my $uuid = shift;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::AssetServer::Config::SYS_SQL{select_asset_by_uuid}, $uuid);
+ my $count = @$result;
+ if ($count > 0) {
+ return $result->[0];
+ }
+ Carp::croak("can not find asset($uuid)");
+}
+
+sub saveAsset {
+ my $asset = shift;
+ my $result = &OpenSim::Utility::getSimpleResult(
+ $OpenSim::AssetServer::Config::SYS_SQL{insert_asset},
+ $asset->{id},
+ $asset->{name},
+ $asset->{description},
+ $asset->{assetType},
+ $asset->{invType},
+ $asset->{"local"},
+ $asset->{temporary},
+ $asset->{data}
+ );
+}
+
+1;
diff --git a/share/perl/lib/OpenSim/AssetServer/Config.pm b/share/perl/lib/OpenSim/AssetServer/Config.pm
new file mode 100644
index 0000000..5598921
--- /dev/null
+++ b/share/perl/lib/OpenSim/AssetServer/Config.pm
@@ -0,0 +1,24 @@
+package OpenSim::AssetServer::Config;
+
+use strict;
+
+our %SYS_SQL = (
+ select_asset_by_uuid =>
+ "SELECT * FROM assets WHERE id=X?",
+ insert_asset =>
+ "INSERT INTO assets VALUES (?,?,?,?,?,?,?,?)"
+);
+
+
+our @ASSETS_COLUMNS = (
+ "id",
+ "name",
+ "description",
+ "assetType",
+ "invType",
+ "local",
+ "temporary",
+ "data",
+);
+
+1;
diff --git a/share/perl/lib/OpenSim/Config.pm b/share/perl/lib/OpenSim/Config.pm
new file mode 100644
index 0000000..246ef26
--- /dev/null
+++ b/share/perl/lib/OpenSim/Config.pm
@@ -0,0 +1,41 @@
+package OpenSim::Config;
+
+# REGION keys
+our $SIM_RECV_KEY = "";
+our $SIM_SEND_KEY = "";
+# ASSET server url
+#our $ASSET_SERVER_URL = "http://127.0.0.1:8003/";
+our $ASSET_SERVER_URL = "http://opensim.wolfdrawer.net:80/asset.cgi";
+our $ASSET_RECV_KEY = "";
+our $ASSET_SEND_KEY = "";
+# USER server url
+#our $USER_SERVER_URL = "http://127.0.0.1:8001/";
+our $USER_SERVER_URL = "http://opensim.wolfdrawer.net:80/user.cgi";
+our $USER_RECV_KEY = "";
+our $USER_SEND_KEY = "";
+# GRID server url
+#our $GRID_SERVER_URL = "http://127.0.0.1:8001/";
+our $GRID_SERVER_URL = "http://opensim.wolfdrawer.net:80/grid.cgi";
+our $GRID_RECV_KEY = "";
+our $GRID_SEND_KEY = "";
+# INVENTORY server url
+#our $INVENTORY_SERVER_URL = "http://127.0.0.1:8004";
+our $INVENTORY_SERVER_URL = "http://opensim.wolfdrawer.net:80/inventory.cgi";
+# DB
+our $DSN = "dbi:mysql:database=opensim;host=192.168.0.20";
+our $DBUSER = "lulu";
+our $DBPASS = "1234";
+
+# DEBUG LOG
+our $DEBUG_LOGDIR = "/home/lulu/temp/opensim";
+
+# MSG
+our %SYS_MSG = (
+ FATAL => "You must have been eaten by a wolf.",
+ FAIL => "Late! There is a wolf behind you",
+ LOGIN_WELCOME => "Do you fear the wolf ?",
+);
+
+
+1;
+
diff --git a/share/perl/lib/OpenSim/GridServer.pm b/share/perl/lib/OpenSim/GridServer.pm
new file mode 100644
index 0000000..7b21cd8
--- /dev/null
+++ b/share/perl/lib/OpenSim/GridServer.pm
@@ -0,0 +1,208 @@
+package OpenSim::GridServer;
+
+use strict;
+use OpenSim::Utility;
+use OpenSim::GridServer::Config;
+use OpenSim::GridServer::GridManager;
+
+sub getHandlerList {
+ my %list = (
+ "simulator_login" => \&_simulator_login,
+ "simulator_data_request" => \&_simulator_data_request,
+ "map_block" => \&_map_block,
+ "map_block2" => \&_map_block2, # this is better for the Region Monitor
+ );
+ return \%list;
+}
+
+# #################
+# XMLRPC Handlers
+sub _simulator_login {
+ my $params = shift;
+
+ my $region_data = undef;
+ my %response = ();
+ if ($params->{"UUID"}) {
+ $region_data = &OpenSim::GridServer::GridManager::getRegionByUUID($params->{"UUID"});
+ } elsif ($params->{"region_handle"}) {
+ $region_data = &OpenSim::GridServer::GridManager::getRegionByHandle($params->{"region_handle"});
+ } else {
+ $response{"error"} = "No UUID or region_handle passed to grid server - unable to connect you";
+ return \%response;
+ }
+
+ if (!$region_data) {
+ my %new_region_data = (
+ uuid => undef,
+ regionHandle => OpenSim::Utility::UIntsToLong($params->{region_locx}*256, $params->{region_locx}*256),
+ regionName => $params->{sim_name},
+ regionRecvKey => $OpenSim::Config::SIM_RECV_KEY,
+ regionSendKey => $OpenSim::Config::SIM_SEND_KEY,
+ regionSecret => $OpenSim::Config::SIM_RECV_KEY,
+ regionDataURI => "",
+ serverIP => $params->{sim_ip},
+ serverPort => $params->{sim_port},
+ serverURI => "http://" + $params->{sim_ip} + ":" + $params->{sim_port} + "/",
+ LocX => $params->{region_locx},
+ LocY => $params->{region_locy},
+ LocZ => 0,
+ regionAssetURI => $OpenSim::Config::ASSET_SERVER_URL,
+ regionAssetRecvKey => $OpenSim::Config::ASSET_RECV_KEY,
+ regionAssetSendKey => $OpenSim::Config::ASSET_SEND_KEY,
+ regionUserURI => $OpenSim::Config::USER_SERVER_URL,
+ regionUserRecvKey => $OpenSim::Config::USER_RECV_KEY,
+ regionUserSendKey => $OpenSim::Config::USER_SEND_KEY,
+ regionMapTextureID => $params->{"map-image-id"},
+ serverHttpPort => $params->{http_port},
+ serverRemotingPort => $params->{remoting_port},
+ );
+ eval {
+ &OpenSim::GridServer::GridManager::addRegion(\%new_region_data);
+ };
+ if ($@) {
+ $response{"error"} = "unable to add region";
+ return \%response;
+ }
+ $region_data = \%new_region_data;
+ }
+
+ my @region_neighbours_data = ();
+ my $region_list = &OpenSim::GridServer::GridManager::getRegionList($region_data->{locX}-1, $region_data->{locY}-1, $region_data->{locX}+1, $region_data->{locY}+1);
+ foreach my $region (@$region_list) {
+ next if ($region->{regionHandle} eq $region_data->{regionHandle});
+ my %neighbour_block = (
+ "sim_ip" => $region->{serverIP},
+ "sim_port" => $region->{serverPort},
+ "region_locx" => $region->{locX},
+ "region_locy" => $region->{locY},
+ "UUID" => $region->{uuid},
+ "regionHandle" => $region->{regionHandle},
+ );
+ push @region_neighbours_data, \%neighbour_block;
+ }
+
+ %response = (
+ UUID => $region_data->{uuid},
+ region_locx => $region_data->{locX},
+ region_locy => $region_data->{locY},
+ regionname => $region_data->{regionName},
+ estate_id => "1", # TODO ???
+ neighbours => \@region_neighbours_data,
+ sim_ip => $region_data->{serverIP},
+ sim_port => $region_data->{serverPort},
+ asset_url => $region_data->{regionAssetURI},
+ asset_recvkey => $region_data->{regionAssetRecvKey},
+ asset_sendkey => $region_data->{regionAssetSendKey},
+ user_url => $region_data->{regionUserURI},
+ user_recvkey => $region_data->{regionUserRecvKey},
+ user_sendkey => $region_data->{regionUserSendKey},
+ authkey => $region_data->{regionSecret},
+ data_uri => $region_data->{regionDataURI},
+ "allow_forceful_banlines" => "TRUE",
+ );
+
+ return \%response;
+}
+
+sub _simulator_data_request {
+ my $params = shift;
+
+ my $region_data = undef;
+ my %response = ();
+ if ($params->{"region_UUID"}) {
+ $region_data = &OpenSim::GridServer::GridManager::getRegionByUUID($params->{"region_UUID"});
+ } elsif ($params->{"region_handle"}) {
+ $region_data = &OpenSim::GridServer::GridManager::getRegionByHandle($params->{"region_handle"});
+ }
+ if (!$region_data) {
+ $response{"error"} = "Sim does not exist";
+ return \%response;
+ }
+
+ $response{"sim_ip"} = $region_data->{serverIP};
+ $response{"sim_port"} = $region_data->{serverPort};
+ $response{"http_port"} = $region_data->{serverHttpPort};
+ $response{"remoting_port"} = $region_data->{serverRemotingPort};
+ $response{"region_locx"} = $region_data->{locX};
+ $response{"region_locy"} = $region_data->{locY};
+ $response{"region_UUID"} = $region_data->{uuid};
+ $response{"region_name"} = $region_data->{regionName};
+ $response{"regionHandle"} = $region_data->{regionHandle};
+
+ return \%response;
+}
+
+sub _map_block {
+ my $params = shift;
+
+ my $xmin = $params->{xmin} || 980;
+ my $ymin = $params->{ymin} || 980;
+ my $xmax = $params->{xmax} || 1020;
+ my $ymax = $params->{ymax} || 1020;
+
+ my @sim_block_list = ();
+ my $region_list = &OpenSim::GridServer::GridManager::getRegionList($xmin, $ymin, $xmax, $ymax);
+ foreach my $region (@$region_list) {
+ my %sim_block = (
+ "x" => $region->{locX},
+ "y" => $region->{locY},
+ "name" => $region->{regionName},
+ "access" => 0, # TODO ? meaning unknown
+ "region-flags" => 0, # TODO ? unknown
+ "water-height" => 20, # TODO ? get from a XML
+ "agents" => 1, # TODO
+ "map-image-id" => $region->{regionMapTexture},
+ "regionhandle" => $region->{regionHandle},
+ "sim_ip" => $region->{serverIP},
+ "sim_port" => $region->{serverPort},
+ "sim_uri" => $region->{serverURI},
+ "uuid" => $region->{uuid},
+ "remoting_port" => $region->{serverRemotingPort},
+ );
+ push @sim_block_list, \%sim_block;
+ }
+
+ my %response = (
+ "sim-profiles" => \@sim_block_list,
+ );
+ return \%response;
+}
+
+sub _map_block2 {
+ my $params = shift;
+
+ my $xmin = $params->{xmin} || 980;
+ my $ymin = $params->{ymin} || 980;
+ my $xmax = $params->{xmax} || 1020;
+ my $ymax = $params->{ymax} || 1020;
+
+ my @sim_block_list = ();
+ my $region_list = &OpenSim::GridServer::GridManager::getRegionList2($xmin, $ymin, $xmax, $ymax);
+ foreach my $region (@$region_list) {
+ my %sim_block = (
+ "x" => $region->{locX},
+ "y" => $region->{locY},
+ "name" => $region->{regionName},
+ "access" => 0, # TODO ? meaning unknown
+ "region-flags" => 0, # TODO ? unknown
+ "water-height" => 20, # TODO ? get from a XML
+ "agents" => 1, # TODO
+ "map-image-id" => $region->{regionMapTexture},
+ "regionhandle" => $region->{regionHandle},
+ "sim_ip" => $region->{serverIP},
+ "sim_port" => $region->{serverPort},
+ "sim_uri" => $region->{serverURI},
+ "uuid" => $region->{uuid},
+ "remoting_port" => $region->{serverRemotingPort},
+ );
+ push @sim_block_list, \%sim_block;
+ }
+
+ my %response = (
+ "sim-profiles" => \@sim_block_list,
+ );
+ return \%response;
+}
+
+1;
+
diff --git a/share/perl/lib/OpenSim/GridServer/Config.pm b/share/perl/lib/OpenSim/GridServer/Config.pm
new file mode 100644
index 0000000..dc72e5a
--- /dev/null
+++ b/share/perl/lib/OpenSim/GridServer/Config.pm
@@ -0,0 +1,50 @@
+package OpenSim::GridServer::Config;
+
+use strict;
+
+our %SYS_SQL = (
+ select_region_by_uuid =>
+ "SELECT * FROM regions WHERE uuid=?",
+ select_region_by_handle =>
+ "SELECT * FROM regions WHERE regionHandle=?",
+ select_region_list =>
+ "SELECT * FROM regions WHERE locX>=? AND locX=? AND locY
+ "SELECT * FROM regions WHERE locX>=? AND locX=? AND locY
+ "INSERT INTO regions VALUES (?????????)",
+ delete_all_regions =>
+ "delete from regions",
+);
+
+
+our @REGIONS_COLUMNS = (
+ "uuid",
+ "regionHandle",
+ "regionName",
+ "regionRecvKey",
+ "regionSendKey",
+ "regionSecret",
+ "regionDataURI",
+ "serverIP",
+ "serverPort",
+ "serverURI",
+ "locX",
+ "locY",
+ "locZ",
+ "eastOverrideHandle",
+ "westOverrideHandle",
+ "southOverrideHandle",
+ "northOverrideHandle",
+ "regionAssetURI",
+ "regionAssetRecvKey",
+ "regionAssetSendKey",
+ "regionUserURI",
+ "regionUserRecvKey",
+ "regionUserSendKey",
+ "regionMapTexture",
+ "serverHttpPort",
+ "serverRemotingPort",
+);
+
+1;
diff --git a/share/perl/lib/OpenSim/GridServer/GridManager.pm b/share/perl/lib/OpenSim/GridServer/GridManager.pm
new file mode 100644
index 0000000..2170d74
--- /dev/null
+++ b/share/perl/lib/OpenSim/GridServer/GridManager.pm
@@ -0,0 +1,57 @@
+package OpenSim::GridServer::GridManager;
+
+use strict;
+use Carp;
+use OpenSim::Utility;
+use OpenSim::GridServer::Config;
+
+sub getRegionByUUID {
+ my $uuid = shift;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::GridServer::Config::SYS_SQL{select_region_by_uuid}, $uuid);
+ my $count = @$result;
+ if ($count > 0) {
+ return $result->[0];
+ }
+ Carp::croak("can not find region");
+}
+
+sub getRegionByHandle {
+ my $handle = shift;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::GridServer::Config::SYS_SQL{select_region_by_handle}, $handle);
+ my $count = @$result;
+ if ($count > 0) {
+ return $result->[0];
+ }
+ Carp::croak("can not find region # $handle");
+}
+
+sub getRegionList {
+ my ($xmin, $ymin, $xmax, $ymax) = @_;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::GridServer::Config::SYS_SQL{select_region_list}, $xmin, $xmax, $ymin, $ymax);
+ my $count = @$result;
+ if ($count > 0) {
+ return $result;
+ }
+ Carp::croak("can not find region");
+}
+
+sub getRegionList2 {
+ my ($xmin, $ymin, $xmax, $ymax) = @_;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::GridServer::Config::SYS_SQL{select_region_list2}, $xmin, $xmax, $ymin, $ymax);
+ my $count = @$result;
+ if ($count > 0) {
+ return $result;
+ }
+ Carp::croak("can not find region");
+}
+
+sub deleteRegions {
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::GridServer::Config::SYS_SQL{delete_all_regions});
+ my $count = @$result;
+ if ($count > 0) {
+ return $result;
+ }
+ Carp::croak("failed to delete regions");
+}
+
+1;
diff --git a/share/perl/lib/OpenSim/InventoryServer.pm b/share/perl/lib/OpenSim/InventoryServer.pm
new file mode 100644
index 0000000..184e19a
--- /dev/null
+++ b/share/perl/lib/OpenSim/InventoryServer.pm
@@ -0,0 +1,249 @@
+package OpenSim::InventoryServer;
+
+use strict;
+use XML::Serializer;
+use OpenSim::Utility;
+use OpenSim::Config;
+use OpenSim::InventoryServer::Config;
+use OpenSim::InventoryServer::InventoryManager;
+
+my $METHOD_LIST = undef;
+
+sub getHandlerList {
+ if (!$METHOD_LIST) {
+ my %list = (
+ "GetInventory" => \&_get_inventory,
+ "CreateInventory" => \&_create_inventory,
+ "NewFolder" => \&_new_folder,
+ "MoveFolder" => \&_move_folder,
+ "NewItem" => \&_new_item,
+ "DeleteItem" => \&_delete_item,
+ "RootFolders" => \&_root_folders,
+ );
+ $METHOD_LIST = \%list;
+ }
+ return $METHOD_LIST;
+}
+
+# #################
+# Handlers
+sub _get_inventory {
+ my $post_data = shift;
+ my $uuid = &_get_uuid($post_data);
+ my $inventry_folders = &OpenSim::InventoryServer::InventoryManager::getUserInventoryFolders($uuid);
+ my @response_folders = ();
+ foreach (@$inventry_folders) {
+ my $folder = &_convert_to_response_folder($_);
+ push @response_folders, $folder;
+ }
+ my $inventry_items = &OpenSim::InventoryServer::InventoryManager::getUserInventoryItems($uuid);
+ my @response_items = ();
+ foreach (@$inventry_items) {
+ my $item = &_convert_to_response_item($_);
+ push @response_items, $item;
+ }
+ my $response_obj = {
+ Folders => { InventoryFolderBase => \@response_folders },
+ AllItems => { InventoryItemBase => \@response_items },
+ UserID => { UUID => $uuid },
+ };
+ my $serializer = new XML::Serializer( $response_obj, "InventoryCollection");
+ return $serializer->to_formatted(XML::Serializer::WITH_HEADER); # TODO:
+}
+
+sub _create_inventory {
+ my $post_data = shift;
+ my $uuid = &_get_uuid($post_data);
+ my $InventoryFolders = &_create_default_inventory($uuid);
+ foreach (@$InventoryFolders) {
+ &OpenSim::InventoryServer::InventoryManager::saveInventoryFolder($_);
+ }
+ my $serializer = new XML::Serializer("true", "boolean");
+ return $serializer->to_formatted(XML::Serializer::WITH_HEADER); # TODO:
+}
+
+sub _new_folder {
+ my $post_data = shift;
+ my $request_obj = &OpenSim::Utility::XML2Obj($post_data);
+ my $folder = &_convert_to_db_folder($request_obj);
+ &OpenSim::InventoryServer::InventoryManager::saveInventoryFolder($folder);
+ my $serializer = new XML::Serializer("true", "boolean");
+ return $serializer->to_formatted(XML::Serializer::WITH_HEADER); # TODO:
+}
+
+sub _move_folder {
+ my $post_data = shift;
+ my $request_info = &OpenSim::Utility::XML2Obj($post_data);
+ &OpenSim::InventoryServer::InventoryManager::moveInventoryFolder($request_info);
+ my $serializer = new XML::Serializer("true", "boolean");
+ return $serializer->to_formatted(XML::Serializer::WITH_HEADER); # TODO:
+}
+
+sub _new_item {
+ my $post_data = shift;
+ my $request_obj = &OpenSim::Utility::XML2Obj($post_data);
+ my $item = &_convert_to_db_item($request_obj);
+ &OpenSim::InventoryServer::InventoryManager::saveInventoryItem($item);
+ my $serializer = new XML::Serializer("true", "boolean");
+ return $serializer->to_formatted(XML::Serializer::WITH_HEADER); # TODO:
+}
+
+sub _delete_item {
+ my $post_data = shift;
+ my $request_obj = &OpenSim::Utility::XML2Obj($post_data);
+ my $item_id = $request_obj->{inventoryID}->{UUID};
+ &OpenSim::InventoryServer::InventoryManager::deleteInventoryItem($item_id);
+ my $serializer = new XML::Serializer("true", "boolean");
+ return $serializer->to_formatted(XML::Serializer::WITH_HEADER); # TODO:
+}
+
+sub _root_folders {
+ my $post_data = shift;
+ my $uuid = &_get_uuid($post_data);
+ my $response = undef;
+ my $inventory_root_folder = &OpenSim::InventoryServer::InventoryManager::getRootFolder($uuid);
+ if ($inventory_root_folder) {
+ my $root_folder_id = $inventory_root_folder->{folderID};
+ my $root_folder = &_convert_to_response_folder($inventory_root_folder);
+ my $root_folders = &OpenSim::InventoryServer::InventoryManager::getChildrenFolders($root_folder_id);
+ my @folders = ($root_folder);
+ foreach(@$root_folders) {
+ my $folder = &_convert_to_response_folder($_);
+ push @folders, $folder;
+ }
+ $response = { InventoryFolderBase => \@folders };
+ } else {
+ $response = ""; # TODO: need better failed message
+ }
+ my $serializer = new XML::Serializer($response, "ArrayOfInventoryFolderBase");
+ return $serializer->to_formatted(XML::Serializer::WITH_HEADER); # TODO:
+}
+
+# #################
+# subfunctions
+sub _convert_to_db_item {
+ my $item = shift;
+ my $ret = {
+ inventoryID => $item->{inventoryID}->{UUID},
+ assetID => $item->{assetID}->{UUID},
+ assetType => $item->{assetType},
+ invType => $item->{invType},
+ parentFolderID => $item->{parentFolderID}->{UUID},
+ avatarID => $item->{avatarID}->{UUID},
+ creatorID => $item->{creatorsID}->{UUID}, # TODO: human error ???
+ inventoryName => $item->{inventoryName},
+ inventoryDescription => $item->{inventoryDescription} || "",
+ inventoryNextPermissions => $item->{inventoryNextPermissions},
+ inventoryCurrentPermissions => $item->{inventoryCurrentPermissions},
+ inventoryBasePermissions => $item->{inventoryBasePermissions},
+ inventoryEveryOnePermissions => $item->{inventoryEveryOnePermissions},
+ };
+ return $ret;
+}
+
+sub _convert_to_response_item {
+ my $item = shift;
+ my $ret = {
+ inventoryID => { UUID => $item->{inventoryID} },
+ assetID => { UUID => $item->{assetID} },
+ assetType => $item->{assetType},
+ invType => $item->{invType},
+ parentFolderID => { UUID => $item->{parentFolderID} },
+ avatarID => { UUID => $item->{avatarID} },
+ creatorsID => { UUID => $item->{creatorID} }, # TODO: human error ???
+ inventoryName => $item->{inventoryName},
+ inventoryDescription => $item->{inventoryDescription} || "",
+ inventoryNextPermissions => $item->{inventoryNextPermissions},
+ inventoryCurrentPermissions => $item->{inventoryCurrentPermissions},
+ inventoryBasePermissions => $item->{inventoryBasePermissions},
+ inventoryEveryOnePermissions => $item->{inventoryEveryOnePermissions},
+ };
+ return $ret;
+}
+
+sub _convert_to_db_folder {
+ my $folder = shift;
+ my $ret = {
+ folderName => $folder->{name},
+ agentID => $folder->{agentID}->{UUID},
+ parentFolderID => $folder->{parentID}->{UUID},
+ folderID => $folder->{folderID}->{UUID},
+ type => $folder->{type},
+ version => $folder->{version},
+ };
+ return $ret;
+}
+
+sub _convert_to_response_folder {
+ my $folder = shift;
+ my $ret = {
+ name => $folder->{folderName},
+ agentID => { UUID => $folder->{agentID} },
+ parentID => { UUID => $folder->{parentFolderID} },
+ folderID => { UUID => $folder->{folderID} },
+ type => $folder->{type},
+ version => $folder->{version},
+ };
+ return $ret;
+}
+
+sub _create_default_inventory {
+ my $uuid = shift;
+
+ my @InventoryFolders = ();
+ my $root_folder_id = &OpenSim::Utility::GenerateUUID();
+
+ push @InventoryFolders, {
+ "folderID" => $root_folder_id,
+ "agentID" => $uuid,
+ "parentFolderID" => &OpenSim::Utility::ZeroUUID(),
+ "folderName" => "My Inventory",
+ "type" => 8,
+ "version" => 1,
+ };
+
+ push @InventoryFolders, {
+ "folderID" => &OpenSim::Utility::GenerateUUID(),
+ "agentID" => $uuid,
+ "parentFolderID" => $root_folder_id,
+ "folderName" => "Textures",
+ "type" => 0,
+ "version" => 1,
+ };
+
+ push @InventoryFolders, {
+ "folderID" => &OpenSim::Utility::GenerateUUID(),
+ "agentID" => $uuid,
+ "parentFolderID" => $root_folder_id,
+ "folderName" => "Objects",
+ "type" => 6,
+ "version" => 1,
+ };
+
+ push @InventoryFolders, {
+ "folderID" => &OpenSim::Utility::GenerateUUID(),
+ "agentID" => $uuid,
+ "parentFolderID" => $root_folder_id,
+ "folderName" => "Clothes",
+ "type" => 5,
+ "version" => 1,
+ };
+
+ return \@InventoryFolders;
+}
+
+
+# #################
+# Utilities
+sub _get_uuid {
+ my $data = shift;
+ if ($data =~ /([^<]+)<\/guid>/) {
+ return $1;
+ } else {
+ Carp::croak("can not find uuid: $data");
+ }
+}
+
+
+1;
+
diff --git a/share/perl/lib/OpenSim/InventoryServer/Config.pm b/share/perl/lib/OpenSim/InventoryServer/Config.pm
new file mode 100644
index 0000000..64dbdd1
--- /dev/null
+++ b/share/perl/lib/OpenSim/InventoryServer/Config.pm
@@ -0,0 +1,51 @@
+package OpenSim::InventoryServer::Config;
+
+use strict;
+
+our %SYS_SQL = (
+ save_inventory_folder =>
+ "REPLACE INTO inventoryfolders VALUES (?,?,?,?,?,?)",
+ save_inventory_item =>
+ "REPLACE INTO inventoryitems VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)",
+ get_root_folder =>
+ "SELECT * FROM inventoryfolders WHERE parentFolderID=? AND agentId=?",
+ get_children_folders =>
+ "SELECT * FROM inventoryfolders WHERE parentFolderID=?",
+ get_user_inventory_folders =>
+ "SELECT * FROM inventoryfolders WHERE agentID=?",
+ get_user_inventory_items =>
+ "SELECT * FROM inventoryitems WHERE avatarID=?",
+ delete_inventory_item =>
+ "DELETE FROM inventoryitems WHERE inventoryID=?",
+ move_inventory_folder =>
+ "UPDATE inventoryfolders SET parentFolderID=? WHERE folderID=?",
+);
+
+
+our @INVENTORYFOLDERS_COLUMNS = (
+ "folderID",
+ "agentID",
+ "parentFolderID",
+ "folderName",
+ "type",
+ "version",
+);
+
+our @INVENTORYITEMS_COLUMNS = (
+ "inventoryID",
+ "assetID",
+ "type",
+ "parentFolderID",
+ "avatarID",
+ "inventoryName",
+ "inventoryDescription",
+ "inventoryNextPermissions",
+ "inventoryCurrentPermissions",
+ "assetType",
+ "invType",
+ "creatorID",
+ "inventoryBasePermissions",
+ "inventoryEveryOnePermissions",
+);
+
+1;
diff --git a/share/perl/lib/OpenSim/InventoryServer/InventoryManager.pm b/share/perl/lib/OpenSim/InventoryServer/InventoryManager.pm
new file mode 100644
index 0000000..97111b7
--- /dev/null
+++ b/share/perl/lib/OpenSim/InventoryServer/InventoryManager.pm
@@ -0,0 +1,86 @@
+package OpenSim::InventoryServer::InventoryManager;
+
+use strict;
+use Carp;
+use OpenSim::Utility;
+use OpenSim::InventoryServer::Config;
+
+sub saveInventoryFolder {
+ my $folder = shift;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::InventoryServer::Config::SYS_SQL{save_inventory_folder},
+ $folder->{"folderID"},
+ $folder->{"agentID"},
+ $folder->{"parentFolderID"},
+ $folder->{"folderName"},
+ $folder->{"type"},
+ $folder->{"version"});
+}
+
+sub saveInventoryItem {
+ my $item = shift;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::InventoryServer::Config::SYS_SQL{save_inventory_item},
+ $item->{"inventoryID"},
+ $item->{"assetID"},
+ $item->{"type"},
+ $item->{"parentFolderID"},
+ $item->{"avatarID"},
+ $item->{"inventoryName"},
+ $item->{"inventoryDescription"},
+ $item->{"inventoryNextPermissions"},
+ $item->{"inventoryCurrentPermissions"},
+ $item->{"assetType"},
+ $item->{"invType"},
+ $item->{"creatorID"},
+ $item->{"inventoryBasePermissions"},
+ $item->{"inventoryEveryOnePermissions"});
+}
+
+sub getRootFolder {
+ my $agent_id = shift;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::InventoryServer::Config::SYS_SQL{get_root_folder},
+ &OpenSim::Utility::ZeroUUID(),
+ $agent_id);
+ my $count = @$result;
+ if ($count > 0) {
+ return $result->[0];
+ } else {
+ return undef;
+ }
+}
+
+sub getChildrenFolders {
+ my $parent_id = shift;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::InventoryServer::Config::SYS_SQL{get_children_folders}, $parent_id);
+ return $result;
+}
+
+sub getUserInventoryFolders {
+ my $agent_id = shift;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::InventoryServer::Config::SYS_SQL{get_user_inventory_folders},
+ $agent_id);
+ return $result;
+}
+
+sub getUserInventoryItems {
+ my $agent_id = shift;
+ my $result = &OpenSim::Utility::getSimpleResult($OpenSim::InventoryServer::Config::SYS_SQL{get_user_inventory_items},
+ $agent_id);
+ return $result;
+}
+
+sub deleteInventoryItem {
+ my $item_id = shift;
+ &OpenSim::Utility::getSimpleResult($OpenSim::InventoryServer::Config::SYS_SQL{delete_inventory_item},
+ $item_id);
+}
+
+sub moveInventoryFolder {
+ my $info = shift;
+ &OpenSim::Utility::getSimpleResult($OpenSim::InventoryServer::Config::SYS_SQL{move_inventory_folder},
+ $info->{parentID}->{UUID}, # TODO: not good
+ $info->{folderID}->{UUID}, # TODO: not good UUID should be extracted in the higher level
+ );
+}
+
+1;
+
diff --git a/share/perl/lib/OpenSim/UserServer.pm b/share/perl/lib/OpenSim/UserServer.pm
new file mode 100644
index 0000000..77117e1
--- /dev/null
+++ b/share/perl/lib/OpenSim/UserServer.pm
@@ -0,0 +1,239 @@
+package OpenSim::UserServer;
+
+use strict;
+use OpenSim::Config;
+use OpenSim::UserServer::Config;
+use OpenSim::UserServer::UserManager;
+
+sub getHandlerList {
+ my %list = (
+ "login_to_simulator" => \&_login_to_simulator,
+ "get_user_by_name" => \&_get_user_by_name,
+ "get_user_by_uuid" => \&_get_user_by_uuid,
+ "get_avatar_picker_avatar" => \&_get_avatar_picker_avatar,
+ );
+ return \%list;
+}
+
+# #################
+# Handlers
+sub _login_to_simulator {
+ my $params = shift;
+ # check params
+ if (!$params->{first} || !$params->{last} || !$params->{passwd}) {
+ return &_make_false_response("not enough params", $OpenSim::Config::SYS_MSG{FATAL});
+ }
+ # select user (check passwd)
+ my $user = &OpenSim::UserServer::UserManager::getUserByName($params->{first}, $params->{last});
+ if ($user->{passwordHash} ne $params->{passwd}) {
+ &_make_false_response("password not match", $OpenSim::Config::SYS_MSG{FAIL});
+ }
+
+ # contact with Grid server
+ my %grid_request_params = (
+ region_handle => $user->{homeRegion},
+ authkey => undef
+ );
+ my $grid_response = &OpenSim::Utility::XMLRPCCall($OpenSim::Config::GRID_SERVER_URL, "simulator_data_request", \%grid_request_params);
+ my $region_server_url = "http://" . $grid_response->{sim_ip} . ":" . $grid_response->{http_port};
+
+ # contact with Region server
+ my $session_id = &OpenSim::Utility::GenerateUUID;
+ my $secure_session_id = &OpenSim::Utility::GenerateUUID;
+ my $circuit_code = int(rand() * 1000000000); # just a random integer
+ my $caps_id = &OpenSim::Utility::GenerateUUID;
+ my %region_request_params = (
+ session_id => $session_id,
+ secure_session_id => $secure_session_id,
+ firstname => $user->{username},
+ lastname => $user->{lastname},
+ agent_id => $user->{UUID},
+ circuit_code => $circuit_code,
+ startpos_x => $user->{homeLocationX},
+ startpos_y => $user->{homeLocationY},
+ startpos_z => $user->{homeLocationZ},
+ regionhandle => $user->{homeRegion},
+ caps_path => $caps_id,
+ );
+ my $region_response = &OpenSim::Utility::XMLRPCCall($region_server_url, "expect_user", \%region_request_params);
+
+ # contact with Inventory server
+ my $inventory_data = &_create_inventory_data($user->{UUID});
+
+ # return to client
+ my %response = (
+ # login info
+ login => "true",
+ session_id => $session_id,
+ secure_session_id => $secure_session_id,
+ # agent
+ first_name => $user->{username},
+ last_name => $user->{lastname},
+ agent_id => $user->{UUID},
+ agent_access => "M", # TODO: do not know its meaning, hard coding in opensim
+ # grid
+ start_location => $params->{start},
+ sim_ip => $grid_response->{sim_ip},
+ sim_port => $grid_response->{sim_port},
+ #sim_port => 9001,
+ region_x => $grid_response->{region_locx} * 256,
+ region_y => $grid_response->{region_locy} * 256,
+ # other
+ inventory_host => undef, # inv13-mysql
+ circuit_code => $circuit_code,
+ message => $OpenSim::Config::SYS_MSG{LOGIN_WELCOME},
+ seconds_since_epoch => time,
+ seed_capability => $region_server_url . "/CAPS/" . $caps_id . "0000/", # https://sim2734.agni.lindenlab.com:12043/cap/61d6d8a0-2098-7eb4-2989-76265d80e9b6
+ look_at => &_make_r_string($user->{homeLookAtX}, $user->{homeLookAtY}, $user->{homeLookAtZ}),
+ home => &_make_home_string(
+ [$grid_response->{region_locx} * 256, $grid_response->{region_locy} * 256],
+ [$user->{homeLocationX}, $user->{homeLocationY}, $user->{homeLocationX}],
+ [$user->{homeLookAtX}, $user->{homeLookAtY}, $user->{homeLookAtZ}]),
+ "inventory-skeleton" => $inventory_data->{InventoryArray},
+ "inventory-root" => [ { folder_id => $inventory_data->{RootFolderID} } ],
+ "event_notifications" => \@OpenSim::UserServer::Config::event_notifications,
+ "event_categories" => \@OpenSim::UserServer::Config::event_categories,
+ "global-textures" => \@OpenSim::UserServer::Config::global_textures,
+ "inventory-lib-owner" => \@OpenSim::UserServer::Config::inventory_lib_owner,
+ "inventory-skel-lib" => \@OpenSim::UserServer::Config::inventory_skel_lib, # hard coding in OpenSim
+ "inventory-lib-root" => \@OpenSim::UserServer::Config::inventory_lib_root,
+ "classified_categories" => \@OpenSim::UserServer::Config::classified_categories,
+ "login-flags" => \@OpenSim::UserServer::Config::login_flags,
+ "initial-outfit" => \@OpenSim::UserServer::Config::initial_outfit,
+ "gestures" => \@OpenSim::UserServer::Config::gestures,
+ "ui-config" => \@OpenSim::UserServer::Config::ui_config,
+ );
+ return \%response;
+}
+
+sub _get_user_by_name {
+ my $param = shift;
+
+ if ($param->{avatar_name}) {
+ my ($first, $last) = split(/\s+/, $param->{avatar_name});
+ my $user = &OpenSim::UserServer::UserManager::getUserByName($first, $last);
+ if (!$user) {
+ return &_unknown_user_response;
+ }
+ return &_convert_to_response($user);
+ } else {
+ return &_unknown_user_response;
+ }
+}
+
+sub _get_user_by_uuid {
+ my $param = shift;
+
+ if ($param->{avatar_uuid}) {
+ my $user = &OpenSim::UserServer::UserManager::getUserByUUID($param->{avatar_uuid});
+ if (!$user) {
+ return &_unknown_user_response;
+ }
+ return &_convert_to_response($user);
+ } else {
+ return &_unknown_user_response;
+ }
+}
+
+sub _get_avatar_picker_avatar {
+}
+
+# #################
+# sub functions
+sub _create_inventory_data {
+ my $user_id = shift;
+ # TODO : too bad!! -> URI encoding
+ my $postdata =<< "POSTDATA";
+POSTDATA=$user_id
+POSTDATA
+ my $res = &OpenSim::Utility::HttpPostRequest($OpenSim::Config::INVENTORY_SERVER_URL . "/RootFolders/", $postdata);
+ my $res_obj = &OpenSim::Utility::XML2Obj($res);
+ if (!$res_obj->{InventoryFolderBase}) {
+ &OpenSim::Utility::HttpPostRequest($OpenSim::Config::INVENTORY_SERVER_URL . "/CreateInventory/", $postdata);
+ # Sleep(10000); # TODO: need not to do this
+ $res = &OpenSim::Utility::HttpPostRequest($OpenSim::Config::INVENTORY_SERVER_URL . "/RootFolders/", $postdata);
+ $res_obj = &OpenSim::Utility::XML2Obj($res);
+ }
+ my $folders = $res_obj->{InventoryFolderBase};
+ my $folders_count = @$folders;
+ if ($folders_count > 0) {
+ my @AgentInventoryFolders = ();
+ my $root_uuid = &OpenSim::Utility::ZeroUUID();
+ foreach my $folder (@$folders) {
+ if ($folder->{parentID}->{UUID} eq &OpenSim::Utility::ZeroUUID()) {
+ $root_uuid = $folder->{folderID}->{UUID};
+ }
+ my %folder_hash = (
+ name => $folder->{name},
+ parent_id => $folder->{parentID}->{UUID},
+ version => $folder->{version},
+ type_default => $folder->{type},
+ folder_id => $folder->{folderID}->{UUID},
+ );
+ push @AgentInventoryFolders, \%folder_hash;
+ }
+ return { InventoryArray => \@AgentInventoryFolders, RootFolderID => $root_uuid };
+ } else {
+ # TODO: impossible ???
+ }
+ return undef;
+}
+
+sub _convert_to_response {
+ my $user = shift;
+ my %response = (
+ firstname => $user->{username},
+ lastname => $user->{lastname},
+ uuid => $user->{UUID},
+ server_inventory => $user->{userInventoryURI},
+ server_asset => $user->{userAssetURI},
+ profile_about => $user->{profileAboutText},
+ profile_firstlife_about => $user->{profileFirstText},
+ profile_firstlife_image => $user->{profileFirstImage},
+ profile_can_do => $user->{profileCanDoMask} || "0",
+ profile_want_do => $user->{profileWantDoMask} || "0",
+ profile_image => $user->{profileImage},
+ profile_created => $user->{created},
+ profile_lastlogin => $user->{lastLogin} || "0",
+ home_coordinates_x => $user->{homeLocationX},
+ home_coordinates_y => $user->{homeLocationY},
+ home_coordinates_z => $user->{homeLocationZ},
+ home_region => $user->{homeRegion} || 0,
+ home_look_x => $user->{homeLookAtX},
+ home_look_y => $user->{homeLookAtY},
+ home_look_z => $user->{homeLookAtZ},
+ );
+ return \%response;
+}
+
+# #################
+# Utility Functions
+sub _make_false_response {
+ my ($reason, $message) = @_;
+ return { reason => $reason, login => "false", message => $message };
+}
+
+sub _unknown_user_response {
+ return {
+ error_type => "unknown_user",
+ error_desc => "The user requested is not in the database",
+ };
+}
+
+sub _make_home_string {
+ my ($region_handle, $position, $look_at) = @_;
+ my $region_handle_string = "'region_handle':" . &_make_r_string(@$region_handle);
+ my $position_string = "'position':" . &_make_r_string(@$position);
+ my $look_at_string = "'look_at':" . &_make_r_string(@$look_at);
+ return "{" . $region_handle_string . ", " . $position_string . ", " . $look_at_string . "}";
+}
+
+sub _make_r_string {
+ my @params = @_;
+ foreach (@params) {
+ $_ = "r" . $_;
+ }
+ return "[" . join(",", @params) . "]";
+}
+
+1;
diff --git a/share/perl/lib/OpenSim/UserServer/Config.pm b/share/perl/lib/OpenSim/UserServer/Config.pm
new file mode 100644
index 0000000..da628ed
--- /dev/null
+++ b/share/perl/lib/OpenSim/UserServer/Config.pm
@@ -0,0 +1,125 @@
+package OpenSim::UserServer::Config;
+
+use strict;
+
+our %SYS_SQL = (
+ select_user_by_name =>
+ "select * from users where username=? and lastname=?",
+ select_user_by_uuid =>
+ "select * from users where uuid=?",
+ create_user =>
+ "insert into users values(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)",
+);
+
+our @USERS_COLUMNS = (
+ "UUID",
+ "username",
+ "lastname",
+ "passwordHash",
+ "passwordSalt",
+ "homeRegion",
+ "homeLocationX",
+ "homeLocationY",
+ "homeLocationZ",
+ "homeLookAtX",
+ "homeLookAtY",
+ "homeLookAtZ",
+ "created",
+ "lastLogin",
+ "userInventoryURI",
+ "userAssetURI",
+ "profileCanDoMask",
+ "profileWantDoMask",
+ "profileAboutText",
+ "profileFirstText",
+ "profileImage",
+ "profileFirstImage",
+);
+
+# copied from opensim
+our @classified_categories = (
+ { category_id => 1, category_name => "Shopping" },
+ { category_id => 2, category_name => "Land Rental" },
+ { category_id => 3, category_name => "Property Rental" },
+ { category_id => 4, category_name => "Special Attraction" },
+ { category_id => 5, category_name => "New Products" },
+ { category_id => 6, category_name => "Employment" },
+ { category_id => 7, category_name => "Wanted" },
+ { category_id => 8, category_name => "Service" },
+ { category_id => 9, category_name => "Personal" },
+);
+
+our @event_categories = ();
+our @event_notifications = ();
+our @gestures =();
+our @global_textures = (
+ {
+ cloud_texture_id => "dc4b9f0b-d008-45c6-96a4-01dd947ac621",
+ moon_texture_id => "ec4b9f0b-d008-45c6-96a4-01dd947ac621",
+ sun_texture_id => "cce0f112-878f-4586-a2e2-a8f104bba271",
+ },
+);
+our @initial_outfit = (
+ { folder_name => "Nightclub Female", gender => "female" }
+);
+our @inventory_lib_owner = ({ agent_id => "11111111-1111-0000-0000-000100bba000" });
+our @inventory_lib_root = ({ folder_id => "00000112-000f-0000-0000-000100bba000" });
+our @inventory_root = ({ folder_id => "2eb27bc2-22ee-48db-b2e9-5c79a6582919" });
+our @inventory_skel_lib = (
+ {
+ folder_id => "00000112-000f-0000-0000-000100bba000",
+ name => "OpenSim Library",
+ parent_id => "00000000-0000-0000-0000-000000000000",
+ type_default => -1,
+ version => 1,
+ },
+ {
+ folder_id => "00000112-000f-0000-0000-000100bba001",
+ name => "Texture Library",
+ parent_id => "00000112-000f-0000-0000-000100bba000",
+ type_default => -1,
+ version => 1,
+ },
+);
+our @inventory_skeleton = (
+ {
+ folder_id => "2eb27bc2-22ee-48db-b2e9-5c79a6582919",
+ name => "My Inventory",
+ parent_id => "00000000-0000-0000-0000-000000000000",
+ type_default => 8,
+ version => 1,
+ },
+ {
+ folder_id => "6cc20d86-9945-4997-a102-959348d56821",
+ name => "Textures",
+ parent_id => "2eb27bc2-22ee-48db-b2e9-5c79a6582919",
+ type_default => 0,
+ version => 1,
+ },
+ {
+ folder_id => "840b747f-bb7d-465e-ab5a-58badc953484",
+ name => "Clothes",
+ parent_id => "2eb27bc2-22ee-48db-b2e9-5c79a6582919",
+ type_default => 5,
+ version => 1,
+ },
+ {
+ folder_id => "37039005-7bbe-42a2-aa12-6bda453f37fd",
+ name => "Objects",
+ parent_id => "2eb27bc2-22ee-48db-b2e9-5c79a6582919",
+ type_default => 6,
+ version => 1,
+ },
+);
+our @login_flags = (
+ {
+ daylight_savings => "N",
+ ever_logged_in => "Y",
+ gendered => "Y",
+ stipend_since_login => "N",
+ },
+);
+our @ui_config = ({ allow_first_life => "Y" });
+
+1;
+
diff --git a/share/perl/lib/OpenSim/UserServer/UserManager.pm b/share/perl/lib/OpenSim/UserServer/UserManager.pm
new file mode 100644
index 0000000..ce35329
--- /dev/null
+++ b/share/perl/lib/OpenSim/UserServer/UserManager.pm
@@ -0,0 +1,49 @@
+package OpenSim::UserServer::UserManager;
+
+use strict;
+use Carp;
+use OpenSim::Utility;
+use OpenSim::UserServer::Config;
+
+sub getUserByName {
+ my ($first, $last) = @_;
+ my $res = &OpenSim::Utility::getSimpleResult($OpenSim::UserServer::Config::SYS_SQL{select_user_by_name}, $first, $last);
+ my $count = @$res;
+ my %user = ();
+ if ($count == 1) {
+ my $user_row = $res->[0];
+ foreach (@OpenSim::UserServer::Config::USERS_COLUMNS) {
+ $user{$_} = $user_row->{$_} || "";
+ }
+ } else {
+ Carp::croak("user not found");
+ }
+ return \%user;
+}
+
+sub getUserByUUID {
+ my ($uuid) = @_;
+ my $res = &OpenSim::Utility::getSimpleResult($OpenSim::UserServer::Config::SYS_SQL{select_user_by_uuid}, $uuid);
+ my $count = @$res;
+ my %user = ();
+ if ($count == 1) {
+ my $user_row = $res->[0];
+ foreach (@OpenSim::UserServer::Config::USERS_COLUMNS) {
+ $user{$_} = $user_row->{$_} || "";
+ }
+ } else {
+ Carp::croak("user not found");
+ }
+ return \%user;
+}
+
+sub createUser {
+ my $user = shift;
+ my @params = ();
+ foreach (@OpenSim::UserServer::Config::USERS_COLUMNS) {
+ push @params, $user->{$_};
+ }
+ my $res = &OpenSim::Utility::getSimpleResult($OpenSim::UserServer::Config::SYS_SQL{create_user}, @params);
+}
+
+1;
diff --git a/share/perl/lib/OpenSim/Utility.pm b/share/perl/lib/OpenSim/Utility.pm
new file mode 100644
index 0000000..7fc91e7
--- /dev/null
+++ b/share/perl/lib/OpenSim/Utility.pm
@@ -0,0 +1,155 @@
+package OpenSim::Utility;
+
+use strict;
+use XML::RPC;
+use XML::Simple;
+use Data::UUID;
+use DBHandler;
+use OpenSim::Config;
+use Socket;
+
+sub XMLRPCCall {
+ my ($url, $methodname, $param) = @_;
+ my $xmlrpc = new XML::RPC($url);
+ my $result = $xmlrpc->call($methodname, $param);
+ return $result;
+}
+
+sub XMLRPCCall_array {
+ my ($url, $methodname, $param) = @_;
+ my $xmlrpc = new XML::RPC($url);
+ my $result = $xmlrpc->call($methodname, @$param);
+ return $result;
+}
+
+sub UIntsToLong {
+ my ($int1, $int2) = @_;
+ return $int1 * 4294967296 + $int2;
+}
+
+sub getSimpleResult {
+ my ($sql, @args) = @_;
+ my $dbh = &DBHandler::getConnection($OpenSim::Config::DSN, $OpenSim::Config::DBUSER, $OpenSim::Config::DBPASS);
+ my $st = new Statement($dbh, $sql);
+ return $st->exec(@args);
+}
+
+sub GenerateUUID {
+ my $ug = new Data::UUID();
+ my $uuid = $ug->create();
+ return $ug->to_string($uuid);
+}
+
+sub ZeroUUID {
+ return "00000000-0000-0000-0000-000000000000";
+}
+
+sub HEX2UUID {
+ my $hex = shift;
+ Carp::croak("$hex is not a uuid") if (length($hex) != 32);
+ my @sub_uuids = ($hex =~ /(\w{8})(\w{4})(\w{4})(\w{4})(\w{12})/);
+ return join("-", @sub_uuids);
+}
+
+sub BIN2UUID {
+ # TODO:
+}
+
+sub UUID2HEX {
+ my $uuid = shift;
+ $uuid =~ s/-//g;
+ return $uuid;
+}
+
+sub UUID2BIN {
+ my $uuid = shift;
+ return pack("H*", &UUID2HEX($uuid));
+}
+
+sub HttpPostRequest {
+ my ($url, $postdata) = @_;
+ $url =~ /http:\/\/([^:\/]+)(:([0-9]+))?(\/.*)?/;
+ my ($host, $port, $path) = ($1, $3, $4);
+ $port ||= 80;
+ $path ||= "/";
+ my $CRLF= "\015\012";
+ my $addr = (gethostbyname($host))[4];
+ my $name = pack('S n a4 x8', 2, $port, $addr);
+ my $data_len = length($postdata);
+ socket(SOCK, PF_INET, SOCK_STREAM, 0);
+ connect(SOCK, $name) ;
+ select(SOCK); $| = 1; select(STDOUT);
+ print SOCK "POST $path HTTP/1.0$CRLF";
+ print SOCK "Host: $host:$port$CRLF";
+ print SOCK "Content-Length: $data_len$CRLF";
+ print SOCK "$CRLF";
+ print SOCK $postdata;
+
+ my $ret = "";
+ unless () {
+ close(SOCK);
+ Carp::croak("can not connect to $url");
+ }
+ my $header = "";
+ while () {
+ $header .= $_;
+ last if ($_ eq $CRLF);
+ }
+ if ($header != /200/) {
+ return $ret;
+ }
+ while () {
+ $ret .= $_;
+ }
+ return $ret;
+}
+# TODO : merge with POST
+sub HttpGetRequest {
+ my ($url) = @_;
+ $url =~ /http:\/\/([^:\/]+)(:([0-9]+))?(\/.*)?/;
+ my ($host, $port, $path) = ($1, $3, $4);
+ $port ||= 80;
+ $path ||= "/";
+ my $CRLF= "\015\012";
+ my $addr = (gethostbyname($host))[4];
+ my $name = pack('S n a4 x8', 2, $port, $addr);
+ socket(SOCK, PF_INET, SOCK_STREAM, 0);
+ connect(SOCK, $name) ;
+ select(SOCK); $| = 1; select(STDOUT);
+ print SOCK "GET $path HTTP/1.0$CRLF";
+ print SOCK "Host: $host:$port$CRLF";
+ print SOCK "$CRLF";
+
+ unless () {
+ close(SOCK);
+ Carp::croak("can not connect to $url");
+ }
+ while () {
+ last if ($_ eq $CRLF);
+ }
+ my $ret = "";
+ while () {
+ $ret .= $_;
+ }
+ return $ret;
+}
+
+sub XML2Obj {
+ my $xml = shift;
+ my $xs = new XML::Simple( keyattr=>[] );
+ return $xs->XMLin($xml);
+}
+
+sub Log {
+ my $server_name = shift;
+ my @param = @_;
+ open(FILE, ">>" . $OpenSim::Config::DEBUG_LOGDIR . "/" . $server_name . ".log");
+ foreach(@param) {
+ print FILE $_ . "\n";
+ }
+ print FILE "<<<<<<<<<<<=====================\n\n";
+ close(FILE);
+}
+
+1;
+
diff --git a/share/perl/lib/XML/RPC.pm b/share/perl/lib/XML/RPC.pm
new file mode 100644
index 0000000..2e08867
--- /dev/null
+++ b/share/perl/lib/XML/RPC.pm
@@ -0,0 +1,217 @@
+package XML::RPC;
+
+use strict;
+use XML::TreePP;
+use Data::Dumper;
+use vars qw($VERSION $faultCode);
+no strict 'refs';
+
+$VERSION = 0.5;
+
+sub new {
+ my $package = shift;
+ my $self = { };
+ bless $self, $package;
+ $self->{url} = shift;
+ $self->{tpp} = XML::TreePP->new(@_);
+ return $self;
+}
+
+sub call {
+ my $self = shift;
+ my ( $methodname, @params ) = @_;
+
+ die 'no url' if ( !$self->{url} );
+
+ $faultCode = 0;
+ my $xml = $self->create_call_xml( $methodname, @params );
+#print STDERR $xml;
+ my $result = $self->{tpp}->parsehttp(
+ POST => $self->{url},
+ $xml,
+ {
+ 'Content-Type' => 'text/xml',
+ 'User-Agent' => 'XML-RPC/' . $VERSION,
+ 'Content-Length' => length($xml)
+ }
+ );
+
+ my @data = $self->unparse_response($result);
+ return @data == 1 ? $data[0] : @data;
+}
+
+sub receive {
+ my $self = shift;
+ my $result = eval {
+ my $xml = shift || die 'no xml';
+ my $handler = shift || die 'no handler';
+ my $hash = $self->{tpp}->parse($xml);
+ my ( $methodname, @params ) = $self->unparse_call($hash);
+ $self->create_response_xml( $handler->( $methodname, @params ) );
+ };
+ return $self->create_fault_xml($@) if ($@);
+ return $result;
+
+}
+
+sub create_fault_xml {
+ my $self = shift;
+ my $error = shift;
+ chomp($error);
+ return $self->{tpp}
+ ->write( { methodResponse => { fault => $self->parse( { faultString => $error, faultCode => $faultCode } ) } } );
+}
+
+sub create_call_xml {
+ my $self = shift;
+ my ( $methodname, @params ) = @_;
+
+ return $self->{tpp}->write(
+ {
+ methodCall => {
+ methodName => $methodname,
+ params => { param => [ map { $self->parse($_) } @params ] }
+ }
+ }
+ );
+}
+
+sub create_response_xml {
+ my $self = shift;
+ my @params = @_;
+
+ return $self->{tpp}->write( { methodResponse => { params => { param => [ map { $self->parse($_) } @params ] } } } );
+}
+
+sub parse {
+ my $self = shift;
+ my $p = shift;
+ my $result;
+
+ if ( ref($p) eq 'HASH' ) {
+ $result = $self->parse_struct($p);
+ }
+ elsif ( ref($p) eq 'ARRAY' ) {
+ $result = $self->parse_array($p);
+ }
+ else {
+ $result = $self->parse_scalar($p);
+ }
+
+ return { value => $result };
+}
+
+sub parse_scalar {
+ my $self = shift;
+ my $scalar = shift;
+ local $^W = undef;
+
+ if ( ( $scalar =~ m/^[\-+]?\d+$/ )
+ && ( abs($scalar) <= ( 0xffffffff >> 1 ) ) )
+ {
+ return { i4 => $scalar };
+ }
+ elsif ( $scalar =~ m/^[\-+]?\d+\.\d+$/ ) {
+ return { double => $scalar };
+ }
+ else {
+ return { string => \$scalar };
+ }
+}
+
+sub parse_struct {
+ my $self = shift;
+ my $hash = shift;
+ my @members;
+ while ( my ( $k, $v ) = each(%$hash) ) {
+ push @members, { name => $k, %{ $self->parse($v) } };
+ }
+ return { struct => { member => \@members } };
+}
+
+sub parse_array {
+ my $self = shift;
+ my $array = shift;
+
+ return { array => { data => { value => [ map { $self->parse($_)->{value} } $self->list($array) ] } } };
+}
+
+sub unparse_response {
+ my $self = shift;
+ my $hash = shift;
+
+ my $response = $hash->{methodResponse} || die 'no data';
+
+ if ( $response->{fault} ) {
+ return $self->unparse_value( $response->{fault}->{value} );
+ }
+ else {
+ return map { $self->unparse_value( $_->{value} ) } $self->list( $response->{params}->{param} );
+ }
+}
+
+sub unparse_call {
+ my $self = shift;
+ my $hash = shift;
+
+ my $response = $hash->{methodCall} || die 'no data';
+
+ my $methodname = $response->{methodName};
+ my @args =
+ map { $self->unparse_value( $_->{value} ) } $self->list( $response->{params}->{param} );
+ return ( $methodname, @args );
+}
+
+sub unparse_value {
+ my $self = shift;
+ my $value = shift;
+ my $result;
+
+ return $value if ( ref($value) ne 'HASH' ); # for unspecified params
+ if ( $value->{struct} ) {
+ $result = $self->unparse_struct( $value->{struct} );
+ return !%$result
+ ? undef
+ : $result; # fix for empty hashrefs from XML::TreePP
+ }
+ elsif ( $value->{array} ) {
+ return $self->unparse_array( $value->{array} );
+ }
+ else {
+ return $self->unparse_scalar($value);
+ }
+}
+
+sub unparse_scalar {
+ my $self = shift;
+ my $scalar = shift;
+ my ($result) = values(%$scalar);
+ return ( ref($result) eq 'HASH' && !%$result )
+ ? undef
+ : $result; # fix for empty hashrefs from XML::TreePP
+}
+
+sub unparse_struct {
+ my $self = shift;
+ my $struct = shift;
+
+ return { map { $_->{name} => $self->unparse_value( $_->{value} ) } $self->list( $struct->{member} ) };
+}
+
+sub unparse_array {
+ my $self = shift;
+ my $array = shift;
+ my $data = $array->{data};
+
+ return [ map { $self->unparse_value($_) } $self->list( $data->{value} ) ];
+}
+
+sub list {
+ my $self = shift;
+ my $param = shift;
+ return () if ( !$param );
+ return @$param if ( ref($param) eq 'ARRAY' );
+ return ($param);
+}
+
+1;
diff --git a/share/perl/lib/XML/Serializer.pm b/share/perl/lib/XML/Serializer.pm
new file mode 100644
index 0000000..6e64f17
--- /dev/null
+++ b/share/perl/lib/XML/Serializer.pm
@@ -0,0 +1,163 @@
+package XML::Serializer;
+
+use strict;
+
+my $root_element = "root";
+my $indent = " ";
+#my $XML_HEADER = << "XMLHEADER";
+#
+#
+#XMLHEADER
+my $XML_HEADER = << "XMLHEADER";
+
+XMLHEADER
+
+sub WITH_HEADER {
+ return 1;
+}
+
+sub new {
+ my ($this, $data, $root_name, $xslt) = @_;
+ my %fields = (
+ _charset => "utf-8",
+ _data => "",
+ _output => "",
+ _root_name => $root_name ? $root_name : "root",
+ _xslt => $xslt ? $xslt : ""
+ );
+ if (defined $data) {
+ $fields{_data} = $data;
+ }
+ return bless \%fields, $this;
+}
+
+sub set_root_name {
+ my ($this, $root_name) = @_;
+ $this->{_root_name} = $root_name;
+}
+
+sub set_data {
+ my ($this, $data) = @_;
+ $this->{_data} = $data;
+}
+
+sub set_charset {
+ my ($this, $charset) = @_;
+ $this->{_charset} = $charset;
+}
+
+sub set_xslt {
+ my ($this, $xslt) = @_;
+ $this->{_xslt} = $xslt;
+}
+
+sub to_string{
+ my ($this, $header) = @_;
+ if ($header) {
+ $this->{_output} = &_make_xml_header($this->{_charset}, $this->{_xslt});
+ }
+ $this->{_output} .= &_to_string($this->{_data}, $this->{_root_name});
+}
+
+sub to_formatted{
+ my ($this, $header) = @_;
+ if ($header) {
+ $this->{_output} = &_make_xml_header($this->{_charset}, $this->{_xslt});
+ }
+ $this->{_output} .= &_to_formatted($this->{_root_name}, $this->{_data});
+}
+
+sub _make_xml_header {
+ my $header = $XML_HEADER;
+ $header =~ s/__CHARSET__/$_[0]/;
+ $header =~ s/__XSLT__/$_[1]/;
+ return $header;
+}
+
+sub _to_string {
+ my ($obj, $name) = @_;
+ my $output = "";
+
+ if (ref($obj) eq "HASH") {
+ my $attr_list = "";
+ my $tmp_mid = "";
+ foreach (sort keys %$obj) {
+ if ($_ =~ /^@/) {
+ $attr_list = &_to_string($_, $obj->{$_});
+ }
+ $tmp_mid .= &_to_string($_, $obj->{$_});
+ }
+ $output = &_start_node($name, $attr_list) . $tmp_mid . &_end_node($name);
+ }
+ elsif (ref($obj) eq "ARRAY") {
+ foreach (@$obj) {
+ $output .= &_to_string($_, $name);
+ }
+ }
+ else {
+ if ($_ =~ /^@(.+)$/) {
+ return "$1=\"$obj\" ";
+ } else {
+ $output = &_start_node($name) . $obj . &_end_node($name);
+ }
+ }
+ return $output;
+}
+
+sub _to_formatted {
+ my ($name, $obj, $depth) = @_;
+# if (!$obj) { $obj = ""; }
+ if (!defined($depth)) { $depth = 0; }
+ my $output = "";
+ if (ref($obj) eq "HASH") {
+ my $attr_list = "";
+ my $tmp_mid = "";
+ foreach (sort keys %$obj) {
+ if ($_ =~ /^@/) {
+ $attr_list = &_to_string($_, $obj->{$_});
+ }
+ $tmp_mid .= &_to_formatted($_, $obj->{$_}, $depth+1);
+ }
+ $output = &_start_node($name, $attr_list, $depth) . "\n" . $tmp_mid . &_end_node($name, $depth);
+ }
+ elsif (ref($obj) eq "ARRAY") {
+ foreach (@$obj) {
+ $output .= &_to_formatted($name, $_, $depth);
+ }
+ }
+ else {
+ if ($_ =~ /^@(.+)$/) {
+ #return "$1=\"$obj\" ";
+ } else {
+ $output .= &_start_node($name, "", $depth);
+ $output .= $obj;
+ $output .= &_end_node($name);
+ }
+ }
+ return $output;
+}
+
+sub _start_node {
+ my $ret = "";
+ if (defined $_[2]) {
+ for(1..$_[2]) { $ret .= $indent; }
+ }
+ my $tag = $_[0] ? $_[0] : "";
+ my $attr = $_[1] ? $_[1] : "";
+ $ret .= "<$tag $attr>";
+ return $ret;
+}
+
+sub _end_node {
+ my $ret = "";
+ if (defined $_[1]) {
+ for(1..$_[1]) { $ret .= $indent; }
+ }
+ if (defined $_[0]) {
+ $ret .= "\n";
+ }
+ return $ret;
+}
+
+1;
+
diff --git a/share/perl/lib/XML/Simple.pm b/share/perl/lib/XML/Simple.pm
new file mode 100644
index 0000000..993669b
--- /dev/null
+++ b/share/perl/lib/XML/Simple.pm
@@ -0,0 +1,3284 @@
+# $Id: Simple.pm,v 1.1 2008/01/18 09:10:19 ryu Exp $
+
+package XML::Simple;
+
+=head1 NAME
+
+XML::Simple - Easy API to maintain XML (esp config files)
+
+=head1 SYNOPSIS
+
+ use XML::Simple;
+
+ my $ref = XMLin([] [, ]);
+
+ my $xml = XMLout($hashref [, ]);
+
+Or the object oriented way:
+
+ require XML::Simple;
+
+ my $xs = XML::Simple->new(options);
+
+ my $ref = $xs->XMLin([] [, ]);
+
+ my $xml = $xs->XMLout($hashref [, ]);
+
+(or see L<"SAX SUPPORT"> for 'the SAX way').
+
+To catch common errors:
+
+ use XML::Simple qw(:strict);
+
+(see L<"STRICT MODE"> for more details).
+
+=cut
+
+# See after __END__ for more POD documentation
+
+
+# Load essentials here, other modules loaded on demand later
+
+use strict;
+use Carp;
+require Exporter;
+
+
+##############################################################################
+# Define some constants
+#
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER);
+
+@ISA = qw(Exporter);
+@EXPORT = qw(XMLin XMLout);
+@EXPORT_OK = qw(xml_in xml_out);
+$VERSION = '2.18';
+$PREFERRED_PARSER = undef;
+
+my $StrictMode = 0;
+
+my @KnownOptIn = qw(keyattr keeproot forcecontent contentkey noattr
+ searchpath forcearray cache suppressempty parseropts
+ grouptags nsexpand datahandler varattr variables
+ normalisespace normalizespace valueattr);
+
+my @KnownOptOut = qw(keyattr keeproot contentkey noattr
+ rootname xmldecl outputfile noescape suppressempty
+ grouptags nsexpand handler noindent attrindent nosort
+ valueattr numericescape);
+
+my @DefKeyAttr = qw(name key id);
+my $DefRootName = qq(opt);
+my $DefContentKey = qq(content);
+my $DefXmlDecl = qq();
+
+my $xmlns_ns = 'http://www.w3.org/2000/xmlns/';
+my $bad_def_ns_jcn = '{' . $xmlns_ns . '}'; # LibXML::SAX workaround
+
+
+##############################################################################
+# Globals for use by caching routines
+#
+
+my %MemShareCache = ();
+my %MemCopyCache = ();
+
+
+##############################################################################
+# Wrapper for Exporter - handles ':strict'
+#
+
+sub import {
+ # Handle the :strict tag
+
+ $StrictMode = 1 if grep(/^:strict$/, @_);
+
+ # Pass everything else to Exporter.pm
+
+ @_ = grep(!/^:strict$/, @_);
+ goto &Exporter::import;
+}
+
+
+##############################################################################
+# Constructor for optional object interface.
+#
+
+sub new {
+ my $class = shift;
+
+ if(@_ % 2) {
+ croak "Default options must be name=>value pairs (odd number supplied)";
+ }
+
+ my %known_opt;
+ @known_opt{@KnownOptIn, @KnownOptOut} = (undef) x 100;
+
+ my %raw_opt = @_;
+ my %def_opt;
+ while(my($key, $val) = each %raw_opt) {
+ my $lkey = lc($key);
+ $lkey =~ s/_//g;
+ croak "Unrecognised option: $key" unless(exists($known_opt{$lkey}));
+ $def_opt{$lkey} = $val;
+ }
+ my $self = { def_opt => \%def_opt };
+
+ return(bless($self, $class));
+}
+
+
+##############################################################################
+# Sub: _get_object()
+#
+# Helper routine called from XMLin() and XMLout() to create an object if none
+# was provided. Note, this routine does mess with the caller's @_ array.
+#
+
+sub _get_object {
+ my $self;
+ if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) {
+ $self = shift;
+ }
+ else {
+ $self = XML::Simple->new();
+ }
+
+ return $self;
+}
+
+
+##############################################################################
+# Sub/Method: XMLin()
+#
+# Exported routine for slurping XML into a hashref - see pod for info.
+#
+# May be called as object method or as a plain function.
+#
+# Expects one arg for the source XML, optionally followed by a number of
+# name => value option pairs.
+#
+
+sub XMLin {
+ my $self = &_get_object; # note, @_ is passed implicitly
+
+ my $target = shift;
+
+
+ # Work out whether to parse a string, a file or a filehandle
+
+ if(not defined $target) {
+ return $self->parse_file(undef, @_);
+ }
+
+ elsif($target eq '-') {
+ local($/) = undef;
+ $target = ;
+ return $self->parse_string(\$target, @_);
+ }
+
+ elsif(my $type = ref($target)) {
+ if($type eq 'SCALAR') {
+ return $self->parse_string($target, @_);
+ }
+ else {
+ return $self->parse_fh($target, @_);
+ }
+ }
+
+ elsif($target =~ m{<.*?>}s) {
+ return $self->parse_string(\$target, @_);
+ }
+
+ else {
+ return $self->parse_file($target, @_);
+ }
+}
+
+
+##############################################################################
+# Sub/Method: parse_file()
+#
+# Same as XMLin, but only parses from a named file.
+#
+
+sub parse_file {
+ my $self = &_get_object; # note, @_ is passed implicitly
+
+ my $filename = shift;
+
+ $self->handle_options('in', @_);
+
+ $filename = $self->default_config_file if not defined $filename;
+
+ $filename = $self->find_xml_file($filename, @{$self->{opt}->{searchpath}});
+
+ # Check cache for previous parse
+
+ if($self->{opt}->{cache}) {
+ foreach my $scheme (@{$self->{opt}->{cache}}) {
+ my $method = 'cache_read_' . $scheme;
+ my $opt = $self->$method($filename);
+ return($opt) if($opt);
+ }
+ }
+
+ my $ref = $self->build_simple_tree($filename, undef);
+
+ if($self->{opt}->{cache}) {
+ my $method = 'cache_write_' . $self->{opt}->{cache}->[0];
+ $self->$method($ref, $filename);
+ }
+
+ return $ref;
+}
+
+
+##############################################################################
+# Sub/Method: parse_fh()
+#
+# Same as XMLin, but only parses from a filehandle.
+#
+
+sub parse_fh {
+ my $self = &_get_object; # note, @_ is passed implicitly
+
+ my $fh = shift;
+ croak "Can't use " . (defined $fh ? qq{string ("$fh")} : 'undef') .
+ " as a filehandle" unless ref $fh;
+
+ $self->handle_options('in', @_);
+
+ return $self->build_simple_tree(undef, $fh);
+}
+
+
+##############################################################################
+# Sub/Method: parse_string()
+#
+# Same as XMLin, but only parses from a string or a reference to a string.
+#
+
+sub parse_string {
+ my $self = &_get_object; # note, @_ is passed implicitly
+
+ my $string = shift;
+
+ $self->handle_options('in', @_);
+
+ return $self->build_simple_tree(undef, ref $string ? $string : \$string);
+}
+
+
+##############################################################################
+# Method: default_config_file()
+#
+# Returns the name of the XML file to parse if no filename (or XML string)
+# was provided.
+#
+
+sub default_config_file {
+ my $self = shift;
+
+ require File::Basename;
+
+ my($basename, $script_dir, $ext) = File::Basename::fileparse($0, '\.[^\.]+');
+
+ # Add script directory to searchpath
+
+ if($script_dir) {
+ unshift(@{$self->{opt}->{searchpath}}, $script_dir);
+ }
+
+ return $basename . '.xml';
+}
+
+
+##############################################################################
+# Method: build_simple_tree()
+#
+# Builds a 'tree' data structure as provided by XML::Parser and then
+# 'simplifies' it as specified by the various options in effect.
+#
+
+sub build_simple_tree {
+ my $self = shift;
+
+ my $tree = $self->build_tree(@_);
+
+ return $self->{opt}->{keeproot}
+ ? $self->collapse({}, @$tree)
+ : $self->collapse(@{$tree->[1]});
+}
+
+
+##############################################################################
+# Method: build_tree()
+#
+# This routine will be called if there is no suitable pre-parsed tree in a
+# cache. It parses the XML and returns an XML::Parser 'Tree' style data
+# structure (summarised in the comments for the collapse() routine below).
+#
+# XML::Simple requires the services of another module that knows how to parse
+# XML. If XML::SAX is installed, the default SAX parser will be used,
+# otherwise XML::Parser will be used.
+#
+# This routine expects to be passed a filename as argument 1 or a 'string' as
+# argument 2. The 'string' might be a string of XML (passed by reference to
+# save memory) or it might be a reference to an IO::Handle. (This
+# non-intuitive mess results in part from the way XML::Parser works but that's
+# really no excuse).
+#
+
+sub build_tree {
+ my $self = shift;
+ my $filename = shift;
+ my $string = shift;
+
+
+ my $preferred_parser = $PREFERRED_PARSER;
+ unless(defined($preferred_parser)) {
+ $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || '';
+ }
+ if($preferred_parser eq 'XML::Parser') {
+ return($self->build_tree_xml_parser($filename, $string));
+ }
+
+ eval { require XML::SAX; }; # We didn't need it until now
+ if($@) { # No XML::SAX - fall back to XML::Parser
+ if($preferred_parser) { # unless a SAX parser was expressly requested
+ croak "XMLin() could not load XML::SAX";
+ }
+ return($self->build_tree_xml_parser($filename, $string));
+ }
+
+ $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser);
+
+ my $sp = XML::SAX::ParserFactory->parser(Handler => $self);
+
+ $self->{nocollapse} = 1;
+ my($tree);
+ if($filename) {
+ $tree = $sp->parse_uri($filename);
+ }
+ else {
+ if(ref($string) && ref($string) ne 'SCALAR') {
+ $tree = $sp->parse_file($string);
+ }
+ else {
+ $tree = $sp->parse_string($$string);
+ }
+ }
+
+ return($tree);
+}
+
+
+##############################################################################
+# Method: build_tree_xml_parser()
+#
+# This routine will be called if XML::SAX is not installed, or if XML::Parser
+# was specifically requested. It takes the same arguments as build_tree() and
+# returns the same data structure (XML::Parser 'Tree' style).
+#
+
+sub build_tree_xml_parser {
+ my $self = shift;
+ my $filename = shift;
+ my $string = shift;
+
+
+ eval {
+ local($^W) = 0; # Suppress warning from Expat.pm re File::Spec::load()
+ require XML::Parser; # We didn't need it until now
+ };
+ if($@) {
+ croak "XMLin() requires either XML::SAX or XML::Parser";
+ }
+
+ if($self->{opt}->{nsexpand}) {
+ carp "'nsexpand' option requires XML::SAX";
+ }
+
+ my $xp = XML::Parser->new(Style => 'Tree', @{$self->{opt}->{parseropts}});
+ my($tree);
+ if($filename) {
+ # $tree = $xp->parsefile($filename); # Changed due to prob w/mod_perl
+ local(*XML_FILE);
+ open(XML_FILE, '<', $filename) || croak qq($filename - $!);
+ $tree = $xp->parse(*XML_FILE);
+ close(XML_FILE);
+ }
+ else {
+ $tree = $xp->parse($$string);
+ }
+
+ return($tree);
+}
+
+
+##############################################################################
+# Method: cache_write_storable()
+#
+# Wrapper routine for invoking Storable::nstore() to cache a parsed data
+# structure.
+#
+
+sub cache_write_storable {
+ my($self, $data, $filename) = @_;
+
+ my $cachefile = $self->storable_filename($filename);
+
+ require Storable; # We didn't need it until now
+
+ if ('VMS' eq $^O) {
+ Storable::nstore($data, $cachefile);
+ }
+ else {
+ # If the following line fails for you, your Storable.pm is old - upgrade
+ Storable::lock_nstore($data, $cachefile);
+ }
+
+}
+
+
+##############################################################################
+# Method: cache_read_storable()
+#
+# Wrapper routine for invoking Storable::retrieve() to read a cached parsed
+# data structure. Only returns cached data if the cache file exists and is
+# newer than the source XML file.
+#
+
+sub cache_read_storable {
+ my($self, $filename) = @_;
+
+ my $cachefile = $self->storable_filename($filename);
+
+ return unless(-r $cachefile);
+ return unless((stat($cachefile))[9] > (stat($filename))[9]);
+
+ require Storable; # We didn't need it until now
+
+ if ('VMS' eq $^O) {
+ return(Storable::retrieve($cachefile));
+ }
+ else {
+ return(Storable::lock_retrieve($cachefile));
+ }
+
+}
+
+
+##############################################################################
+# Method: storable_filename()
+#
+# Translates the supplied source XML filename into a filename for the storable
+# cached data. A '.stor' suffix is added after stripping an optional '.xml'
+# suffix.
+#
+
+sub storable_filename {
+ my($self, $cachefile) = @_;
+
+ $cachefile =~ s{(\.xml)?$}{.stor};
+ return $cachefile;
+}
+
+
+##############################################################################
+# Method: cache_write_memshare()
+#
+# Takes the supplied data structure reference and stores it away in a global
+# hash structure.
+#
+
+sub cache_write_memshare {
+ my($self, $data, $filename) = @_;
+
+ $MemShareCache{$filename} = [time(), $data];
+}
+
+
+##############################################################################
+# Method: cache_read_memshare()
+#
+# Takes a filename and looks in a global hash for a cached parsed version.
+#
+
+sub cache_read_memshare {
+ my($self, $filename) = @_;
+
+ return unless($MemShareCache{$filename});
+ return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]);
+
+ return($MemShareCache{$filename}->[1]);
+
+}
+
+
+##############################################################################
+# Method: cache_write_memcopy()
+#
+# Takes the supplied data structure and stores a copy of it in a global hash
+# structure.
+#
+
+sub cache_write_memcopy {
+ my($self, $data, $filename) = @_;
+
+ require Storable; # We didn't need it until now
+
+ $MemCopyCache{$filename} = [time(), Storable::dclone($data)];
+}
+
+
+##############################################################################
+# Method: cache_read_memcopy()
+#
+# Takes a filename and looks in a global hash for a cached parsed version.
+# Returns a reference to a copy of that data structure.
+#
+
+sub cache_read_memcopy {
+ my($self, $filename) = @_;
+
+ return unless($MemCopyCache{$filename});
+ return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]);
+
+ return(Storable::dclone($MemCopyCache{$filename}->[1]));
+
+}
+
+
+##############################################################################
+# Sub/Method: XMLout()
+#
+# Exported routine for 'unslurping' a data structure out to XML.
+#
+# Expects a reference to a data structure and an optional list of option
+# name => value pairs.
+#
+
+sub XMLout {
+ my $self = &_get_object; # note, @_ is passed implicitly
+
+ croak "XMLout() requires at least one argument" unless(@_);
+ my $ref = shift;
+
+ $self->handle_options('out', @_);
+
+
+ # If namespace expansion is set, XML::NamespaceSupport is required
+
+ if($self->{opt}->{nsexpand}) {
+ require XML::NamespaceSupport;
+ $self->{nsup} = XML::NamespaceSupport->new();
+ $self->{ns_prefix} = 'aaa';
+ }
+
+
+ # Wrap top level arrayref in a hash
+
+ if(UNIVERSAL::isa($ref, 'ARRAY')) {
+ $ref = { anon => $ref };
+ }
+
+
+ # Extract rootname from top level hash if keeproot enabled
+
+ if($self->{opt}->{keeproot}) {
+ my(@keys) = keys(%$ref);
+ if(@keys == 1) {
+ $ref = $ref->{$keys[0]};
+ $self->{opt}->{rootname} = $keys[0];
+ }
+ }
+
+ # Ensure there are no top level attributes if we're not adding root elements
+
+ elsif($self->{opt}->{rootname} eq '') {
+ if(UNIVERSAL::isa($ref, 'HASH')) {
+ my $refsave = $ref;
+ $ref = {};
+ foreach (keys(%$refsave)) {
+ if(ref($refsave->{$_})) {
+ $ref->{$_} = $refsave->{$_};
+ }
+ else {
+ $ref->{$_} = [ $refsave->{$_} ];
+ }
+ }
+ }
+ }
+
+
+ # Encode the hashref and write to file if necessary
+
+ $self->{_ancestors} = [];
+ my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, '');
+ delete $self->{_ancestors};
+
+ if($self->{opt}->{xmldecl}) {
+ $xml = $self->{opt}->{xmldecl} . "\n" . $xml;
+ }
+
+ if($self->{opt}->{outputfile}) {
+ if(ref($self->{opt}->{outputfile})) {
+ my $fh = $self->{opt}->{outputfile};
+ if(UNIVERSAL::isa($fh, 'GLOB') and !UNIVERSAL::can($fh, 'print')) {
+ eval { require IO::Handle; };
+ croak $@ if $@;
+ }
+ return($fh->print($xml));
+ }
+ else {
+ local(*OUT);
+ open(OUT, '>', "$self->{opt}->{outputfile}") ||
+ croak "open($self->{opt}->{outputfile}): $!";
+ binmode(OUT, ':utf8') if($] >= 5.008);
+ print OUT $xml || croak "print: $!";
+ close(OUT);
+ }
+ }
+ elsif($self->{opt}->{handler}) {
+ require XML::SAX;
+ my $sp = XML::SAX::ParserFactory->parser(
+ Handler => $self->{opt}->{handler}
+ );
+ return($sp->parse_string($xml));
+ }
+ else {
+ return($xml);
+ }
+}
+
+
+##############################################################################
+# Method: handle_options()
+#
+# Helper routine for both XMLin() and XMLout(). Both routines handle their
+# first argument and assume all other args are options handled by this routine.
+# Saves a hash of options in $self->{opt}.
+#
+# If default options were passed to the constructor, they will be retrieved
+# here and merged with options supplied to the method call.
+#
+# First argument should be the string 'in' or the string 'out'.
+#
+# Remaining arguments should be name=>value pairs. Sets up default values
+# for options not supplied. Unrecognised options are a fatal error.
+#
+
+sub handle_options {
+ my $self = shift;
+ my $dirn = shift;
+
+
+ # Determine valid options based on context
+
+ my %known_opt;
+ if($dirn eq 'in') {
+ @known_opt{@KnownOptIn} = @KnownOptIn;
+ }
+ else {
+ @known_opt{@KnownOptOut} = @KnownOptOut;
+ }
+
+
+ # Store supplied options in hashref and weed out invalid ones
+
+ if(@_ % 2) {
+ croak "Options must be name=>value pairs (odd number supplied)";
+ }
+ my %raw_opt = @_;
+ my $opt = {};
+ $self->{opt} = $opt;
+
+ while(my($key, $val) = each %raw_opt) {
+ my $lkey = lc($key);
+ $lkey =~ s/_//g;
+ croak "Unrecognised option: $key" unless($known_opt{$lkey});
+ $opt->{$lkey} = $val;
+ }
+
+
+ # Merge in options passed to constructor
+
+ foreach (keys(%known_opt)) {
+ unless(exists($opt->{$_})) {
+ if(exists($self->{def_opt}->{$_})) {
+ $opt->{$_} = $self->{def_opt}->{$_};
+ }
+ }
+ }
+
+
+ # Set sensible defaults if not supplied
+
+ if(exists($opt->{rootname})) {
+ unless(defined($opt->{rootname})) {
+ $opt->{rootname} = '';
+ }
+ }
+ else {
+ $opt->{rootname} = $DefRootName;
+ }
+
+ if($opt->{xmldecl} and $opt->{xmldecl} eq '1') {
+ $opt->{xmldecl} = $DefXmlDecl;
+ }
+
+ if(exists($opt->{contentkey})) {
+ if($opt->{contentkey} =~ m{^-(.*)$}) {
+ $opt->{contentkey} = $1;
+ $opt->{collapseagain} = 1;
+ }
+ }
+ else {
+ $opt->{contentkey} = $DefContentKey;
+ }
+
+ unless(exists($opt->{normalisespace})) {
+ $opt->{normalisespace} = $opt->{normalizespace};
+ }
+ $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace}));
+
+ # Cleanups for values assumed to be arrays later
+
+ if($opt->{searchpath}) {
+ unless(ref($opt->{searchpath})) {
+ $opt->{searchpath} = [ $opt->{searchpath} ];
+ }
+ }
+ else {
+ $opt->{searchpath} = [ ];
+ }
+
+ if($opt->{cache} and !ref($opt->{cache})) {
+ $opt->{cache} = [ $opt->{cache} ];
+ }
+ if($opt->{cache}) {
+ $_ = lc($_) foreach (@{$opt->{cache}});
+ foreach my $scheme (@{$opt->{cache}}) {
+ my $method = 'cache_read_' . $scheme;
+ croak "Unsupported caching scheme: $scheme"
+ unless($self->can($method));
+ }
+ }
+
+ if(exists($opt->{parseropts})) {
+ if($^W) {
+ carp "Warning: " .
+ "'ParserOpts' is deprecated, contact the author if you need it";
+ }
+ }
+ else {
+ $opt->{parseropts} = [ ];
+ }
+
+
+ # Special cleanup for {forcearray} which could be regex, arrayref or boolean
+ # or left to default to 0
+
+ if(exists($opt->{forcearray})) {
+ if(ref($opt->{forcearray}) eq 'Regexp') {
+ $opt->{forcearray} = [ $opt->{forcearray} ];
+ }
+
+ if(ref($opt->{forcearray}) eq 'ARRAY') {
+ my @force_list = @{$opt->{forcearray}};
+ if(@force_list) {
+ $opt->{forcearray} = {};
+ foreach my $tag (@force_list) {
+ if(ref($tag) eq 'Regexp') {
+ push @{$opt->{forcearray}->{_regex}}, $tag;
+ }
+ else {
+ $opt->{forcearray}->{$tag} = 1;
+ }
+ }
+ }
+ else {
+ $opt->{forcearray} = 0;
+ }
+ }
+ else {
+ $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 );
+ }
+ }
+ else {
+ if($StrictMode and $dirn eq 'in') {
+ croak "No value specified for 'ForceArray' option in call to XML$dirn()";
+ }
+ $opt->{forcearray} = 0;
+ }
+
+
+ # Special cleanup for {keyattr} which could be arrayref or hashref or left
+ # to default to arrayref
+
+ if(exists($opt->{keyattr})) {
+ if(ref($opt->{keyattr})) {
+ if(ref($opt->{keyattr}) eq 'HASH') {
+
+ # Make a copy so we can mess with it
+
+ $opt->{keyattr} = { %{$opt->{keyattr}} };
+
+
+ # Convert keyattr => { elem => '+attr' }
+ # to keyattr => { elem => [ 'attr', '+' ] }
+
+ foreach my $el (keys(%{$opt->{keyattr}})) {
+ if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) {
+ $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ];
+ if($StrictMode and $dirn eq 'in') {
+ next if($opt->{forcearray} == 1);
+ next if(ref($opt->{forcearray}) eq 'HASH'
+ and $opt->{forcearray}->{$el});
+ croak "<$el> set in KeyAttr but not in ForceArray";
+ }
+ }
+ else {
+ delete($opt->{keyattr}->{$el}); # Never reached (famous last words?)
+ }
+ }
+ }
+ else {
+ if(@{$opt->{keyattr}} == 0) {
+ delete($opt->{keyattr});
+ }
+ }
+ }
+ else {
+ $opt->{keyattr} = [ $opt->{keyattr} ];
+ }
+ }
+ else {
+ if($StrictMode) {
+ croak "No value specified for 'KeyAttr' option in call to XML$dirn()";
+ }
+ $opt->{keyattr} = [ @DefKeyAttr ];
+ }
+
+
+ # Special cleanup for {valueattr} which could be arrayref or hashref
+
+ if(exists($opt->{valueattr})) {
+ if(ref($opt->{valueattr}) eq 'ARRAY') {
+ $opt->{valueattrlist} = {};
+ $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} });
+ }
+ }
+
+ # make sure there's nothing weird in {grouptags}
+
+ if($opt->{grouptags}) {
+ croak "Illegal value for 'GroupTags' option - expected a hashref"
+ unless UNIVERSAL::isa($opt->{grouptags}, 'HASH');
+
+ while(my($key, $val) = each %{$opt->{grouptags}}) {
+ next if $key ne $val;
+ croak "Bad value in GroupTags: '$key' => '$val'";
+ }
+ }
+
+
+ # Check the {variables} option is valid and initialise variables hash
+
+ if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) {
+ croak "Illegal value for 'Variables' option - expected a hashref";
+ }
+
+ if($opt->{variables}) {
+ $self->{_var_values} = { %{$opt->{variables}} };
+ }
+ elsif($opt->{varattr}) {
+ $self->{_var_values} = {};
+ }
+
+}
+
+
+##############################################################################
+# Method: find_xml_file()
+#
+# Helper routine for XMLin().
+# Takes a filename, and a list of directories, attempts to locate the file in
+# the directories listed.
+# Returns a full pathname on success; croaks on failure.
+#
+
+sub find_xml_file {
+ my $self = shift;
+ my $file = shift;
+ my @search_path = @_;
+
+
+ require File::Basename;
+ require File::Spec;
+
+ my($filename, $filedir) = File::Basename::fileparse($file);
+
+ if($filename ne $file) { # Ignore searchpath if dir component
+ return($file) if(-e $file);
+ }
+ else {
+ my($path);
+ foreach $path (@search_path) {
+ my $fullpath = File::Spec->catfile($path, $file);
+ return($fullpath) if(-e $fullpath);
+ }
+ }
+
+ # If user did not supply a search path, default to current directory
+
+ if(!@search_path) {
+ return($file) if(-e $file);
+ croak "File does not exist: $file";
+ }
+
+ croak "Could not find $file in ", join(':', @search_path);
+}
+
+
+##############################################################################
+# Method: collapse()
+#
+# Helper routine for XMLin(). This routine really comprises the 'smarts' (or
+# value add) of this module.
+#
+# Takes the parse tree that XML::Parser produced from the supplied XML and
+# recurses through it 'collapsing' unnecessary levels of indirection (nested
+# arrays etc) to produce a data structure that is easier to work with.
+#
+# Elements in the original parser tree are represented as an element name
+# followed by an arrayref. The first element of the array is a hashref
+# containing the attributes. The rest of the array contains a list of any
+# nested elements as name+arrayref pairs:
+#
+# , [ { }, , [ ... ], ... ]
+#
+# The special element name '0' (zero) flags text content.
+#
+# This routine cuts down the noise by discarding any text content consisting of
+# only whitespace and then moves the nested elements into the attribute hash
+# using the name of the nested element as the hash key and the collapsed
+# version of the nested element as the value. Multiple nested elements with
+# the same name will initially be represented as an arrayref, but this may be
+# 'folded' into a hashref depending on the value of the keyattr option.
+#
+
+sub collapse {
+ my $self = shift;
+
+
+ # Start with the hash of attributes
+
+ my $attr = shift;
+ if($self->{opt}->{noattr}) { # Discard if 'noattr' set
+ $attr = {};
+ }
+ elsif($self->{opt}->{normalisespace} == 2) {
+ while(my($key, $value) = each %$attr) {
+ $attr->{$key} = $self->normalise_space($value)
+ }
+ }
+
+
+ # Do variable substitutions
+
+ if(my $var = $self->{_var_values}) {
+ while(my($key, $val) = each(%$attr)) {
+ $val =~ s{\$\{([\w.]+)\}}{ $self->get_var($1) }ge;
+ $attr->{$key} = $val;
+ }
+ }
+
+
+ # Roll up 'value' attributes (but only if no nested elements)
+
+ if(!@_ and keys %$attr == 1) {
+ my($k) = keys %$attr;
+ if($self->{opt}->{valueattrlist} and $self->{opt}->{valueattrlist}->{$k}) {
+ return $attr->{$k};
+ }
+ }
+
+
+ # Add any nested elements
+
+ my($key, $val);
+ while(@_) {
+ $key = shift;
+ $val = shift;
+
+ if(ref($val)) {
+ $val = $self->collapse(@$val);
+ next if(!defined($val) and $self->{opt}->{suppressempty});
+ }
+ elsif($key eq '0') {
+ next if($val =~ m{^\s*$}s); # Skip all whitespace content
+
+ $val = $self->normalise_space($val)
+ if($self->{opt}->{normalisespace} == 2);
+
+ # do variable substitutions
+
+ if(my $var = $self->{_var_values}) {
+ $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge;
+ }
+
+
+ # look for variable definitions
+
+ if(my $var = $self->{opt}->{varattr}) {
+ if(exists $attr->{$var}) {
+ $self->set_var($attr->{$var}, $val);
+ }
+ }
+
+
+ # Collapse text content in element with no attributes to a string
+
+ if(!%$attr and !@_) {
+ return($self->{opt}->{forcecontent} ?
+ { $self->{opt}->{contentkey} => $val } : $val
+ );
+ }
+ $key = $self->{opt}->{contentkey};
+ }
+
+
+ # Combine duplicate attributes into arrayref if required
+
+ if(exists($attr->{$key})) {
+ if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) {
+ push(@{$attr->{$key}}, $val);
+ }
+ else {
+ $attr->{$key} = [ $attr->{$key}, $val ];
+ }
+ }
+ elsif(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
+ $attr->{$key} = [ $val ];
+ }
+ else {
+ if( $key ne $self->{opt}->{contentkey}
+ and (
+ ($self->{opt}->{forcearray} == 1)
+ or (
+ (ref($self->{opt}->{forcearray}) eq 'HASH')
+ and (
+ $self->{opt}->{forcearray}->{$key}
+ or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}})
+ )
+ )
+ )
+ ) {
+ $attr->{$key} = [ $val ];
+ }
+ else {
+ $attr->{$key} = $val;
+ }
+ }
+
+ }
+
+
+ # Turn arrayrefs into hashrefs if key fields present
+
+ if($self->{opt}->{keyattr}) {
+ while(($key,$val) = each %$attr) {
+ if(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
+ $attr->{$key} = $self->array_to_hash($key, $val);
+ }
+ }
+ }
+
+
+ # disintermediate grouped tags
+
+ if($self->{opt}->{grouptags}) {
+ while(my($key, $val) = each(%$attr)) {
+ next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
+ next unless(exists($self->{opt}->{grouptags}->{$key}));
+
+ my($child_key, $child_val) = %$val;
+
+ if($self->{opt}->{grouptags}->{$key} eq $child_key) {
+ $attr->{$key}= $child_val;
+ }
+ }
+ }
+
+
+ # Fold hashes containing a single anonymous array up into just the array
+
+ my $count = scalar keys %$attr;
+ if($count == 1
+ and exists $attr->{anon}
+ and UNIVERSAL::isa($attr->{anon}, 'ARRAY')
+ ) {
+ return($attr->{anon});
+ }
+
+
+ # Do the right thing if hash is empty, otherwise just return it
+
+ if(!%$attr and exists($self->{opt}->{suppressempty})) {
+ if(defined($self->{opt}->{suppressempty}) and
+ $self->{opt}->{suppressempty} eq '') {
+ return('');
+ }
+ return(undef);
+ }
+
+
+ # Roll up named elements with named nested 'value' attributes
+
+ if($self->{opt}->{valueattr}) {
+ while(my($key, $val) = each(%$attr)) {
+ next unless($self->{opt}->{valueattr}->{$key});
+ next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
+ my($k) = keys %$val;
+ next unless($k eq $self->{opt}->{valueattr}->{$key});
+ $attr->{$key} = $val->{$k};
+ }
+ }
+
+ return($attr)
+
+}
+
+
+##############################################################################
+# Method: set_var()
+#
+# Called when a variable definition is encountered in the XML. (A variable
+# definition looks like value where attrname
+# matches the varattr setting).
+#
+
+sub set_var {
+ my($self, $name, $value) = @_;
+
+ $self->{_var_values}->{$name} = $value;
+}
+
+
+##############################################################################
+# Method: get_var()
+#
+# Called during variable substitution to get the value for the named variable.
+#
+
+sub get_var {
+ my($self, $name) = @_;
+
+ my $value = $self->{_var_values}->{$name};
+ return $value if(defined($value));
+
+ return '${' . $name . '}';
+}
+
+
+##############################################################################
+# Method: normalise_space()
+#
+# Strips leading and trailing whitespace and collapses sequences of whitespace
+# characters to a single space.
+#
+
+sub normalise_space {
+ my($self, $text) = @_;
+
+ $text =~ s/^\s+//s;
+ $text =~ s/\s+$//s;
+ $text =~ s/\s\s+/ /sg;
+
+ return $text;
+}
+
+
+##############################################################################
+# Method: array_to_hash()
+#
+# Helper routine for collapse().
+# Attempts to 'fold' an array of hashes into an hash of hashes. Returns a
+# reference to the hash on success or the original array if folding is
+# not possible. Behaviour is controlled by 'keyattr' option.
+#
+
+sub array_to_hash {
+ my $self = shift;
+ my $name = shift;
+ my $arrayref = shift;
+
+ my $hashref = $self->new_hashref;
+
+ my($i, $key, $val, $flag);
+
+
+ # Handle keyattr => { .... }
+
+ if(ref($self->{opt}->{keyattr}) eq 'HASH') {
+ return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name}));
+ ($key, $flag) = @{$self->{opt}->{keyattr}->{$name}};
+ for($i = 0; $i < @$arrayref; $i++) {
+ if(UNIVERSAL::isa($arrayref->[$i], 'HASH') and
+ exists($arrayref->[$i]->{$key})
+ ) {
+ $val = $arrayref->[$i]->{$key};
+ if(ref($val)) {
+ $self->die_or_warn("<$name> element has non-scalar '$key' key attribute");
+ return($arrayref);
+ }
+ $val = $self->normalise_space($val)
+ if($self->{opt}->{normalisespace} == 1);
+ $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
+ if(exists($hashref->{$val}));
+ $hashref->{$val} = { %{$arrayref->[$i]} };
+ $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-');
+ delete $hashref->{$val}->{$key} unless($flag eq '+');
+ }
+ else {
+ $self->die_or_warn("<$name> element has no '$key' key attribute");
+ return($arrayref);
+ }
+ }
+ }
+
+
+ # Or assume keyattr => [ .... ]
+
+ else {
+ my $default_keys =
+ join(',', @DefKeyAttr) eq join(',', @{$self->{opt}->{keyattr}});
+
+ ELEMENT: for($i = 0; $i < @$arrayref; $i++) {
+ return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH'));
+
+ foreach $key (@{$self->{opt}->{keyattr}}) {
+ if(defined($arrayref->[$i]->{$key})) {
+ $val = $arrayref->[$i]->{$key};
+ if(ref($val)) {
+ $self->die_or_warn("<$name> element has non-scalar '$key' key attribute")
+ if not $default_keys;
+ return($arrayref);
+ }
+ $val = $self->normalise_space($val)
+ if($self->{opt}->{normalisespace} == 1);
+ $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
+ if(exists($hashref->{$val}));
+ $hashref->{$val} = { %{$arrayref->[$i]} };
+ delete $hashref->{$val}->{$key};
+ next ELEMENT;
+ }
+ }
+
+ return($arrayref); # No keyfield matched
+ }
+ }
+
+ # collapse any hashes which now only have a 'content' key
+
+ if($self->{opt}->{collapseagain}) {
+ $hashref = $self->collapse_content($hashref);
+ }
+
+ return($hashref);
+}
+
+
+##############################################################################
+# Method: die_or_warn()
+#
+# Takes a diagnostic message and does one of three things:
+# 1. dies if strict mode is enabled
+# 2. warns if warnings are enabled but strict mode is not
+# 3. ignores message and resturns silently if neither strict mode nor warnings
+# are enabled
+#
+
+sub die_or_warn {
+ my $self = shift;
+ my $msg = shift;
+
+ croak $msg if($StrictMode);
+ carp "Warning: $msg" if($^W);
+}
+
+
+##############################################################################
+# Method: new_hashref()
+#
+# This is a hook routine for overriding in a sub-class. Some people believe
+# that using Tie::IxHash here will solve order-loss problems.
+#
+
+sub new_hashref {
+ my $self = shift;
+
+ return { @_ };
+}
+
+
+##############################################################################
+# Method: collapse_content()
+#
+# Helper routine for array_to_hash
+#
+# Arguments expected are:
+# - an XML::Simple object
+# - a hasref
+# the hashref is a former array, turned into a hash by array_to_hash because
+# of the presence of key attributes
+# at this point collapse_content avoids over-complicated structures like
+# dir => { libexecdir => { content => '$exec_prefix/libexec' },
+# localstatedir => { content => '$prefix' },
+# }
+# into
+# dir => { libexecdir => '$exec_prefix/libexec',
+# localstatedir => '$prefix',
+# }
+
+sub collapse_content {
+ my $self = shift;
+ my $hashref = shift;
+
+ my $contentkey = $self->{opt}->{contentkey};
+
+ # first go through the values,checking that they are fit to collapse
+ foreach my $val (values %$hashref) {
+ return $hashref unless ( (ref($val) eq 'HASH')
+ and (keys %$val == 1)
+ and (exists $val->{$contentkey})
+ );
+ }
+
+ # now collapse them
+ foreach my $key (keys %$hashref) {
+ $hashref->{$key}= $hashref->{$key}->{$contentkey};
+ }
+
+ return $hashref;
+}
+
+
+##############################################################################
+# Method: value_to_xml()
+#
+# Helper routine for XMLout() - recurses through a data structure building up
+# and returning an XML representation of that structure as a string.
+#
+# Arguments expected are:
+# - the data structure to be encoded (usually a reference)
+# - the XML tag name to use for this item
+# - a string of spaces for use as the current indent level
+#
+
+sub value_to_xml {
+ my $self = shift;;
+
+
+ # Grab the other arguments
+
+ my($ref, $name, $indent) = @_;
+
+ my $named = (defined($name) and $name ne '' ? 1 : 0);
+
+ my $nl = "\n";
+
+ my $is_root = $indent eq '' ? 1 : 0; # Warning, dirty hack!
+ if($self->{opt}->{noindent}) {
+ $indent = '';
+ $nl = '';
+ }
+
+
+ # Convert to XML
+
+ if(ref($ref)) {
+ croak "circular data structures not supported"
+ if(grep($_ == $ref, @{$self->{_ancestors}}));
+ push @{$self->{_ancestors}}, $ref;
+ }
+ else {
+ if($named) {
+ return(join('',
+ $indent, '<', $name, '>',
+ ($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)),
+ '", $nl
+ ));
+ }
+ else {
+ return("$ref$nl");
+ }
+ }
+
+
+ # Unfold hash to array if possible
+
+ if(UNIVERSAL::isa($ref, 'HASH') # It is a hash
+ and keys %$ref # and it's not empty
+ and $self->{opt}->{keyattr} # and folding is enabled
+ and !$is_root # and its not the root element
+ ) {
+ $ref = $self->hash_to_array($name, $ref);
+ }
+
+
+ my @result = ();
+ my($key, $value);
+
+
+ # Handle hashrefs
+
+ if(UNIVERSAL::isa($ref, 'HASH')) {
+
+ # Reintermediate grouped values if applicable
+
+ if($self->{opt}->{grouptags}) {
+ $ref = $self->copy_hash($ref);
+ while(my($key, $val) = each %$ref) {
+ if($self->{opt}->{grouptags}->{$key}) {
+ $ref->{$key} = { $self->{opt}->{grouptags}->{$key} => $val };
+ }
+ }
+ }
+
+
+ # Scan for namespace declaration attributes
+
+ my $nsdecls = '';
+ my $default_ns_uri;
+ if($self->{nsup}) {
+ $ref = $self->copy_hash($ref);
+ $self->{nsup}->push_context();
+
+ # Look for default namespace declaration first
+
+ if(exists($ref->{xmlns})) {
+ $self->{nsup}->declare_prefix('', $ref->{xmlns});
+ $nsdecls .= qq( xmlns="$ref->{xmlns}");
+ delete($ref->{xmlns});
+ }
+ $default_ns_uri = $self->{nsup}->get_uri('');
+
+
+ # Then check all the other keys
+
+ foreach my $qname (keys(%$ref)) {
+ my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
+ if($uri) {
+ if($uri eq $xmlns_ns) {
+ $self->{nsup}->declare_prefix($lname, $ref->{$qname});
+ $nsdecls .= qq( xmlns:$lname="$ref->{$qname}");
+ delete($ref->{$qname});
+ }
+ }
+ }
+
+ # Translate any remaining Clarkian names
+
+ foreach my $qname (keys(%$ref)) {
+ my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
+ if($uri) {
+ if($default_ns_uri and $uri eq $default_ns_uri) {
+ $ref->{$lname} = $ref->{$qname};
+ delete($ref->{$qname});
+ }
+ else {
+ my $prefix = $self->{nsup}->get_prefix($uri);
+ unless($prefix) {
+ # $self->{nsup}->declare_prefix(undef, $uri);
+ # $prefix = $self->{nsup}->get_prefix($uri);
+ $prefix = $self->{ns_prefix}++;
+ $self->{nsup}->declare_prefix($prefix, $uri);
+ $nsdecls .= qq( xmlns:$prefix="$uri");
+ }
+ $ref->{"$prefix:$lname"} = $ref->{$qname};
+ delete($ref->{$qname});
+ }
+ }
+ }
+ }
+
+
+ my @nested = ();
+ my $text_content = undef;
+ if($named) {
+ push @result, $indent, '<', $name, $nsdecls;
+ }
+
+ if(keys %$ref) {
+ my $first_arg = 1;
+ foreach my $key ($self->sorted_keys($name, $ref)) {
+ my $value = $ref->{$key};
+ next if(substr($key, 0, 1) eq '-');
+ if(!defined($value)) {
+ next if $self->{opt}->{suppressempty};
+ unless(exists($self->{opt}->{suppressempty})
+ and !defined($self->{opt}->{suppressempty})
+ ) {
+ carp 'Use of uninitialized value' if($^W);
+ }
+ if($key eq $self->{opt}->{contentkey}) {
+ $text_content = '';
+ }
+ else {
+ $value = exists($self->{opt}->{suppressempty}) ? {} : '';
+ }
+ }
+
+ if(!ref($value)
+ and $self->{opt}->{valueattr}
+ and $self->{opt}->{valueattr}->{$key}
+ ) {
+ $value = { $self->{opt}->{valueattr}->{$key} => $value };
+ }
+
+ if(ref($value) or $self->{opt}->{noattr}) {
+ push @nested,
+ $self->value_to_xml($value, $key, "$indent ");
+ }
+ else {
+ $value = $self->escape_value($value) unless($self->{opt}->{noescape});
+ if($key eq $self->{opt}->{contentkey}) {
+ $text_content = $value;
+ }
+ else {
+ push @result, "\n$indent " . ' ' x length($name)
+ if($self->{opt}->{attrindent} and !$first_arg);
+ push @result, ' ', $key, '="', $value , '"';
+ $first_arg = 0;
+ }
+ }
+ }
+ }
+ else {
+ $text_content = '';
+ }
+
+ if(@nested or defined($text_content)) {
+ if($named) {
+ push @result, ">";
+ if(defined($text_content)) {
+ push @result, $text_content;
+ $nested[0] =~ s/^\s+// if(@nested);
+ }
+ else {
+ push @result, $nl;
+ }
+ if(@nested) {
+ push @result, @nested, $indent;
+ }
+ push @result, '", $nl;
+ }
+ else {
+ push @result, @nested; # Special case if no root elements
+ }
+ }
+ else {
+ push @result, " />", $nl;
+ }
+ $self->{nsup}->pop_context() if($self->{nsup});
+ }
+
+
+ # Handle arrayrefs
+
+ elsif(UNIVERSAL::isa($ref, 'ARRAY')) {
+ foreach $value (@$ref) {
+ next if !defined($value) and $self->{opt}->{suppressempty};
+ if(!ref($value)) {
+ push @result,
+ $indent, '<', $name, '>',
+ ($self->{opt}->{noescape} ? $value : $self->escape_value($value)),
+ '$nl";
+ }
+ elsif(UNIVERSAL::isa($value, 'HASH')) {
+ push @result, $self->value_to_xml($value, $name, $indent);
+ }
+ else {
+ push @result,
+ $indent, '<', $name, ">$nl",
+ $self->value_to_xml($value, 'anon', "$indent "),
+ $indent, '$nl";
+ }
+ }
+ }
+
+ else {
+ croak "Can't encode a value of type: " . ref($ref);
+ }
+
+
+ pop @{$self->{_ancestors}} if(ref($ref));
+
+ return(join('', @result));
+}
+
+
+##############################################################################
+# Method: sorted_keys()
+#
+# Returns the keys of the referenced hash sorted into alphabetical order, but
+# with the 'key' key (as in KeyAttr) first, if there is one.
+#
+
+sub sorted_keys {
+ my($self, $name, $ref) = @_;
+
+ return keys %$ref if $self->{opt}->{nosort};
+
+ my %hash = %$ref;
+ my $keyattr = $self->{opt}->{keyattr};
+
+ my @key;
+
+ if(ref $keyattr eq 'HASH') {
+ if(exists $keyattr->{$name} and exists $hash{$keyattr->{$name}->[0]}) {
+ push @key, $keyattr->{$name}->[0];
+ delete $hash{$keyattr->{$name}->[0]};
+ }
+ }
+ elsif(ref $keyattr eq 'ARRAY') {
+ foreach (@{$keyattr}) {
+ if(exists $hash{$_}) {
+ push @key, $_;
+ delete $hash{$_};
+ last;
+ }
+ }
+ }
+
+ return(@key, sort keys %hash);
+}
+
+##############################################################################
+# Method: escape_value()
+#
+# Helper routine for automatically escaping values for XMLout().
+# Expects a scalar data value. Returns escaped version.
+#
+
+sub escape_value {
+ my($self, $data) = @_;
+
+ return '' unless(defined($data));
+
+ $data =~ s/&/&/sg;
+ $data =~ s//>/sg;
+ $data =~ s/"/"/sg;
+
+ my $level = $self->{opt}->{numericescape} or return $data;
+
+ return $self->numeric_escape($data, $level);
+}
+
+sub numeric_escape {
+ my($self, $data, $level) = @_;
+
+ use utf8; # required for 5.6
+
+ if($self->{opt}->{numericescape} eq '2') {
+ $data =~ s/([^\x00-\x7F])/'&#' . ord($1) . ';'/gse;
+ }
+ else {
+ $data =~ s/([^\x00-\xFF])/'&#' . ord($1) . ';'/gse;
+ }
+
+ return $data;
+}
+
+
+##############################################################################
+# Method: hash_to_array()
+#
+# Helper routine for value_to_xml().
+# Attempts to 'unfold' a hash of hashes into an array of hashes. Returns a
+# reference to the array on success or the original hash if unfolding is
+# not possible.
+#
+
+sub hash_to_array {
+ my $self = shift;
+ my $parent = shift;
+ my $hashref = shift;
+
+ my $arrayref = [];
+
+ my($key, $value);
+
+ my @keys = $self->{opt}->{nosort} ? keys %$hashref : sort keys %$hashref;
+ foreach $key (@keys) {
+ $value = $hashref->{$key};
+ return($hashref) unless(UNIVERSAL::isa($value, 'HASH'));
+
+ if(ref($self->{opt}->{keyattr}) eq 'HASH') {
+ return($hashref) unless(defined($self->{opt}->{keyattr}->{$parent}));
+ push @$arrayref, $self->copy_hash(
+ $value, $self->{opt}->{keyattr}->{$parent}->[0] => $key
+ );
+ }
+ else {
+ push(@$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value });
+ }
+ }
+
+ return($arrayref);
+}
+
+
+##############################################################################
+# Method: copy_hash()
+#
+# Helper routine for hash_to_array(). When unfolding a hash of hashes into
+# an array of hashes, we need to copy the key from the outer hash into the
+# inner hash. This routine makes a copy of the original hash so we don't
+# destroy the original data structure. You might wish to override this
+# method if you're using tied hashes and don't want them to get untied.
+#
+
+sub copy_hash {
+ my($self, $orig, @extra) = @_;
+
+ return { @extra, %$orig };
+}
+
+##############################################################################
+# Methods required for building trees from SAX events
+##############################################################################
+
+sub start_document {
+ my $self = shift;
+
+ $self->handle_options('in') unless($self->{opt});
+
+ $self->{lists} = [];
+ $self->{curlist} = $self->{tree} = [];
+}
+
+
+sub start_element {
+ my $self = shift;
+ my $element = shift;
+
+ my $name = $element->{Name};
+ if($self->{opt}->{nsexpand}) {
+ $name = $element->{LocalName} || '';
+ if($element->{NamespaceURI}) {
+ $name = '{' . $element->{NamespaceURI} . '}' . $name;
+ }
+ }
+ my $attributes = {};
+ if($element->{Attributes}) { # Might be undef
+ foreach my $attr (values %{$element->{Attributes}}) {
+ if($self->{opt}->{nsexpand}) {
+ my $name = $attr->{LocalName} || '';
+ if($attr->{NamespaceURI}) {
+ $name = '{' . $attr->{NamespaceURI} . '}' . $name
+ }
+ $name = 'xmlns' if($name eq $bad_def_ns_jcn);
+ $attributes->{$name} = $attr->{Value};
+ }
+ else {
+ $attributes->{$attr->{Name}} = $attr->{Value};
+ }
+ }
+ }
+ my $newlist = [ $attributes ];
+ push @{ $self->{lists} }, $self->{curlist};
+ push @{ $self->{curlist} }, $name => $newlist;
+ $self->{curlist} = $newlist;
+}
+
+
+sub characters {
+ my $self = shift;
+ my $chars = shift;
+
+ my $text = $chars->{Data};
+ my $clist = $self->{curlist};
+ my $pos = $#$clist;
+
+ if ($pos > 0 and $clist->[$pos - 1] eq '0') {
+ $clist->[$pos] .= $text;
+ }
+ else {
+ push @$clist, 0 => $text;
+ }
+}
+
+
+sub end_element {
+ my $self = shift;
+
+ $self->{curlist} = pop @{ $self->{lists} };
+}
+
+
+sub end_document {
+ my $self = shift;
+
+ delete($self->{curlist});
+ delete($self->{lists});
+
+ my $tree = $self->{tree};
+ delete($self->{tree});
+
+
+ # Return tree as-is to XMLin()
+
+ return($tree) if($self->{nocollapse});
+
+
+ # Or collapse it before returning it to SAX parser class
+
+ if($self->{opt}->{keeproot}) {
+ $tree = $self->collapse({}, @$tree);
+ }
+ else {
+ $tree = $self->collapse(@{$tree->[1]});
+ }
+
+ if($self->{opt}->{datahandler}) {
+ return($self->{opt}->{datahandler}->($self, $tree));
+ }
+
+ return($tree);
+}
+
+*xml_in = \&XMLin;
+*xml_out = \&XMLout;
+
+1;
+
+__END__
+
+=head1 QUICK START
+
+Say you have a script called B and a file of configuration options
+called B containing this:
+
+
+
+ 10.0.0.101
+ 10.0.1.101
+
+
+ 10.0.0.102
+
+
+ 10.0.0.103
+ 10.0.1.103
+
+
+
+The following lines of code in B:
+
+ use XML::Simple;
+
+ my $config = XMLin();
+
+will 'slurp' the configuration options into the hashref $config (because no
+arguments are passed to C the name and location of the XML file will
+be inferred from name and location of the script). You can dump out the
+contents of the hashref using Data::Dumper:
+
+ use Data::Dumper;
+
+ print Dumper($config);
+
+which will produce something like this (formatting has been adjusted for
+brevity):
+
+ {
+ 'logdir' => '/var/log/foo/',
+ 'debugfile' => '/tmp/foo.debug',
+ 'server' => {
+ 'sahara' => {
+ 'osversion' => '2.6',
+ 'osname' => 'solaris',
+ 'address' => [ '10.0.0.101', '10.0.1.101' ]
+ },
+ 'gobi' => {
+ 'osversion' => '6.5',
+ 'osname' => 'irix',
+ 'address' => '10.0.0.102'
+ },
+ 'kalahari' => {
+ 'osversion' => '2.0.34',
+ 'osname' => 'linux',
+ 'address' => [ '10.0.0.103', '10.0.1.103' ]
+ }
+ }
+ }
+
+Your script could then access the name of the log directory like this:
+
+ print $config->{logdir};
+
+similarly, the second address on the server 'kalahari' could be referenced as:
+
+ print $config->{server}->{kalahari}->{address}->[1];
+
+What could be simpler? (Rhetorical).
+
+For simple requirements, that's really all there is to it. If you want to
+store your XML in a different directory or file, or pass it in as a string or
+even pass it in via some derivative of an IO::Handle, you'll need to check out
+L<"OPTIONS">. If you want to turn off or tweak the array folding feature (that
+neat little transformation that produced $config->{server}) you'll find options
+for that as well.
+
+If you want to generate XML (for example to write a modified version of
+$config back out as XML), check out C.
+
+If your needs are not so simple, this may not be the module for you. In that
+case, you might want to read L<"WHERE TO FROM HERE?">.
+
+=head1 DESCRIPTION
+
+The XML::Simple module provides a simple API layer on top of an underlying XML
+parsing module (either XML::Parser or one of the SAX2 parser modules). Two
+functions are exported: C and C. Note: you can explicity
+request the lower case versions of the function names: C and
+C.
+
+The simplest approach is to call these two functions directly, but an
+optional object oriented interface (see L<"OPTIONAL OO INTERFACE"> below)
+allows them to be called as methods of an B object. The object
+interface can also be used at either end of a SAX pipeline.
+
+=head2 XMLin()
+
+Parses XML formatted data and returns a reference to a data structure which
+contains the same information in a more readily accessible form. (Skip
+down to L<"EXAMPLES"> below, for more sample code).
+
+C accepts an optional XML specifier followed by zero or more 'name =>
+value' option pairs. The XML specifier can be one of the following:
+
+=over 4
+
+=item A filename
+
+If the filename contains no directory components C will look for the
+file in each directory in the SearchPath (see L<"OPTIONS"> below) or in the
+current directory if the SearchPath option is not defined. eg:
+
+ $ref = XMLin('/etc/params.xml');
+
+Note, the filename '-' can be used to parse from STDIN.
+
+=item undef
+
+If there is no XML specifier, C will check the script directory and
+each of the SearchPath directories for a file with the same name as the script
+but with the extension '.xml'. Note: if you wish to specify options, you
+must specify the value 'undef'. eg:
+
+ $ref = XMLin(undef, ForceArray => 1);
+
+=item A string of XML
+
+A string containing XML (recognised by the presence of '<' and '>' characters)
+will be parsed directly. eg:
+
+ $ref = XMLin('');
+
+=item An IO::Handle object
+
+An IO::Handle object will be read to EOF and its contents parsed. eg:
+
+ $fh = IO::File->new('/etc/params.xml');
+ $ref = XMLin($fh);
+
+=back
+
+=head2 XMLout()
+
+Takes a data structure (generally a hashref) and returns an XML encoding of
+that structure. If the resulting XML is parsed using C, it should
+return a data structure equivalent to the original (see caveats below).
+
+The C function can also be used to output the XML as SAX events
+see the C option and L<"SAX SUPPORT"> for more details).
+
+When translating hashes to XML, hash keys which have a leading '-' will be
+silently skipped. This is the approved method for marking elements of a
+data structure which should be ignored by C. (Note: If these items
+were not skipped the key names would be emitted as element or attribute names
+with a leading '-' which would not be valid XML).
+
+=head2 Caveats
+
+Some care is required in creating data structures which will be passed to
+C. Hash keys from the data structure will be encoded as either XML
+element names or attribute names. Therefore, you should use hash key names
+which conform to the relatively strict XML naming rules:
+
+Names in XML must begin with a letter. The remaining characters may be
+letters, digits, hyphens (-), underscores (_) or full stops (.). It is also
+allowable to include one colon (:) in an element name but this should only be
+used when working with namespaces (B can only usefully work with
+namespaces when teamed with a SAX Parser).
+
+You can use other punctuation characters in hash values (just not in hash
+keys) however B does not support dumping binary data.
+
+If you break these rules, the current implementation of C will
+simply emit non-compliant XML which will be rejected if you try to read it
+back in. (A later version of B might take a more proactive
+approach).
+
+Note also that although you can nest hashes and arrays to arbitrary levels,
+circular data structures are not supported and will cause C to die.
+
+If you wish to 'round-trip' arbitrary data structures from Perl to XML and back
+to Perl, then you should probably disable array folding (using the KeyAttr
+option) both with C and with C. If you still don't get the
+expected results, you may prefer to use L which is designed for
+exactly that purpose.
+
+Refer to L<"WHERE TO FROM HERE?"> if C is too simple for your needs.
+
+
+=head1 OPTIONS
+
+B supports a number of options (in fact as each release of
+B adds more options, the module's claim to the name 'Simple'
+becomes increasingly tenuous). If you find yourself repeatedly having to
+specify the same options, you might like to investigate L<"OPTIONAL OO
+INTERFACE"> below.
+
+If you can't be bothered reading the documentation, refer to
+L<"STRICT MODE"> to automatically catch common mistakes.
+
+Because there are so many options, it's hard for new users to know which ones
+are important, so here are the two you really need to know about:
+
+=over 4
+
+=item *
+
+check out C because you'll almost certainly want to turn it on
+
+=item *
+
+make sure you know what the C option does and what its default value is
+because it may surprise you otherwise (note in particular that 'KeyAttr'
+affects both C and C)
+
+=back
+
+The option name headings below have a trailing 'comment' - a hash followed by
+two pieces of metadata:
+
+=over 4
+
+=item *
+
+Options are marked with 'I' if they are recognised by C and
+'I' if they are recognised by C.
+
+=item *
+
+Each option is also flagged to indicate whether it is:
+
+ 'important' - don't use the module until you understand this one
+ 'handy' - you can skip this on the first time through
+ 'advanced' - you can skip this on the second time through
+ 'SAX only' - don't worry about this unless you're using SAX (or
+ alternatively if you need this, you also need SAX)
+ 'seldom used' - you'll probably never use this unless you were the
+ person that requested the feature
+
+=back
+
+The options are listed alphabetically:
+
+Note: option names are no longer case sensitive so you can use the mixed case
+versions shown here; all lower case as required by versions 2.03 and earlier;
+or you can add underscores between the words (eg: key_attr).
+
+
+=head2 AttrIndent => 1 I<# out - handy>
+
+When you are using C, enable this option to have attributes printed
+one-per-line with sensible indentation rather than all on one line.
+
+=head2 Cache => [ cache schemes ] I<# in - advanced>
+
+Because loading the B module and parsing an XML file can consume a
+significant number of CPU cycles, it is often desirable to cache the output of
+C for later reuse.
+
+When parsing from a named file, B supports a number of caching
+schemes. The 'Cache' option may be used to specify one or more schemes (using
+an anonymous array). Each scheme will be tried in turn in the hope of finding
+a cached pre-parsed representation of the XML file. If no cached copy is
+found, the file will be parsed and the first cache scheme in the list will be
+used to save a copy of the results. The following cache schemes have been
+implemented:
+
+=over 4
+
+=item storable
+
+Utilises B to read/write a cache file with the same name as the
+XML file but with the extension .stor
+
+=item memshare
+
+When a file is first parsed, a copy of the resulting data structure is retained
+in memory in the B module's namespace. Subsequent calls to parse
+the same file will return a reference to this structure. This cached version
+will persist only for the life of the Perl interpreter (which in the case of
+mod_perl for example, may be some significant time).
+
+Because each caller receives a reference to the same data structure, a change
+made by one caller will be visible to all. For this reason, the reference
+returned should be treated as read-only.
+
+=item memcopy
+
+This scheme works identically to 'memshare' (above) except that each caller
+receives a reference to a new data structure which is a copy of the cached
+version. Copying the data structure will add a little processing overhead,
+therefore this scheme should only be used where the caller intends to modify
+the data structure (or wishes to protect itself from others who might). This
+scheme uses B to perform the copy.
+
+=back
+
+Warning! The memory-based caching schemes compare the timestamp on the file to
+the time when it was last parsed. If the file is stored on an NFS filesystem
+(or other network share) and the clock on the file server is not exactly
+synchronised with the clock where your script is run, updates to the source XML
+file may appear to be ignored.
+
+=head2 ContentKey => 'keyname' I<# in+out - seldom used>
+
+When text content is parsed to a hash value, this option let's you specify a
+name for the hash key to override the default 'content'. So for example:
+
+ XMLin('Text', ContentKey => 'text')
+
+will parse to:
+
+ { 'one' => 1, 'text' => 'Text' }
+
+instead of:
+
+ { 'one' => 1, 'content' => 'Text' }
+
+C will also honour the value of this option when converting a hashref
+to XML.
+
+You can also prefix your selected key name with a '-' character to have
+C try a little harder to eliminate unnecessary 'content' keys after
+array folding. For example:
+
+ XMLin(
+ '- First
- Second
',
+ KeyAttr => {item => 'name'},
+ ForceArray => [ 'item' ],
+ ContentKey => '-content'
+ )
+
+will parse to:
+
+ {
+ 'item' => {
+ 'one' => 'First'
+ 'two' => 'Second'
+ }
+ }
+
+rather than this (without the '-'):
+
+ {
+ 'item' => {
+ 'one' => { 'content' => 'First' }
+ 'two' => { 'content' => 'Second' }
+ }
+ }
+
+=head2 DataHandler => code_ref I<# in - SAX only>
+
+When you use an B object as a SAX handler, it will return a
+'simple tree' data structure in the same format as C would return. If
+this option is set (to a subroutine reference), then when the tree is built the
+subroutine will be called and passed two arguments: a reference to the
+B object and a reference to the data tree. The return value from
+the subroutine will be returned to the SAX driver. (See L<"SAX SUPPORT"> for
+more details).
+
+=head2 ForceArray => 1 I<# in - important>
+
+This option should be set to '1' to force nested elements to be represented
+as arrays even when there is only one. Eg, with ForceArray enabled, this
+XML:
+
+
+ value
+
+
+would parse to this:
+
+ {
+ 'name' => [
+ 'value'
+ ]
+ }
+
+instead of this (the default):
+
+ {
+ 'name' => 'value'
+ }
+
+This option is especially useful if the data structure is likely to be written
+back out as XML and the default behaviour of rolling single nested elements up
+into attributes is not desirable.
+
+If you are using the array folding feature, you should almost certainly enable
+this option. If you do not, single nested elements will not be parsed to
+arrays and therefore will not be candidates for folding to a hash. (Given that
+the default value of 'KeyAttr' enables array folding, the default value of this
+option should probably also have been enabled too - sorry).
+
+=head2 ForceArray => [ names ] I<# in - important>
+
+This alternative (and preferred) form of the 'ForceArray' option allows you to
+specify a list of element names which should always be forced into an array
+representation, rather than the 'all or nothing' approach above.
+
+It is also possible (since version 2.05) to include compiled regular
+expressions in the list - any element names which match the pattern will be
+forced to arrays. If the list contains only a single regex, then it is not
+necessary to enclose it in an arrayref. Eg:
+
+ ForceArray => qr/_list$/
+
+=head2 ForceContent => 1 I<# in - seldom used>
+
+When C parses elements which have text content as well as attributes,
+the text content must be represented as a hash value rather than a simple
+scalar. This option allows you to force text content to always parse to
+a hash value even when there are no attributes. So for example:
+
+ XMLin('text1text2', ForceContent => 1)
+
+will parse to:
+
+ {
+ 'x' => { 'content' => 'text1' },
+ 'y' => { 'a' => 2, 'content' => 'text2' }
+ }
+
+instead of:
+
+ {
+ 'x' => 'text1',
+ 'y' => { 'a' => 2, 'content' => 'text2' }
+ }
+
+=head2 GroupTags => { grouping tag => grouped tag } I<# in+out - handy>
+
+You can use this option to eliminate extra levels of indirection in your Perl
+data structure. For example this XML:
+
+
+
+ /usr/bin
+ /usr/local/bin
+ /usr/X11/bin
+
+
+
+Would normally be read into a structure like this:
+
+ {
+ searchpath => {
+ dir => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ]
+ }
+ }
+
+But when read in with the appropriate value for 'GroupTags':
+
+ my $opt = XMLin($xml, GroupTags => { searchpath => 'dir' });
+
+It will return this simpler structure:
+
+ {
+ searchpath => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ]
+ }
+
+The grouping element (C<< >> in the example) must not contain any
+attributes or elements other than the grouped element.
+
+You can specify multiple 'grouping element' to 'grouped element' mappings in
+the same hashref. If this option is combined with C, the array
+folding will occur first and then the grouped element names will be eliminated.
+
+C will also use the grouptag mappings to re-introduce the tags around
+the grouped elements. Beware though that this will occur in all places that
+the 'grouping tag' name occurs - you probably don't want to use the same name
+for elements as well as attributes.
+
+=head2 Handler => object_ref I<# out - SAX only>
+
+Use the 'Handler' option to have C generate SAX events rather than
+returning a string of XML. For more details see L<"SAX SUPPORT"> below.
+
+Note: the current implementation of this option generates a string of XML
+and uses a SAX parser to translate it into SAX events. The normal encoding
+rules apply here - your data must be UTF8 encoded unless you specify an
+alternative encoding via the 'XMLDecl' option; and by the time the data reaches
+the handler object, it will be in UTF8 form regardless of the encoding you
+supply. A future implementation of this option may generate the events
+directly.
+
+=head2 KeepRoot => 1 I<# in+out - handy>
+
+In its attempt to return a data structure free of superfluous detail and
+unnecessary levels of indirection, C normally discards the root
+element name. Setting the 'KeepRoot' option to '1' will cause the root element
+name to be retained. So after executing this code:
+
+ $config = XMLin('', KeepRoot => 1)
+
+You'll be able to reference the tempdir as
+C<$config-E{config}-E{tempdir}> instead of the default
+C<$config-E{tempdir}>.
+
+Similarly, setting the 'KeepRoot' option to '1' will tell C that the
+data structure already contains a root element name and it is not necessary to
+add another.
+
+=head2 KeyAttr => [ list ] I<# in+out - important>
+
+This option controls the 'array folding' feature which translates nested
+elements from an array to a hash. It also controls the 'unfolding' of hashes
+to arrays.
+
+For example, this XML:
+
+
+
+
+
+
+would, by default, parse to this:
+
+ {
+ 'user' => [
+ {
+ 'login' => 'grep',
+ 'fullname' => 'Gary R Epstein'
+ },
+ {
+ 'login' => 'stty',
+ 'fullname' => 'Simon T Tyson'
+ }
+ ]
+ }
+
+If the option 'KeyAttr => "login"' were used to specify that the 'login'
+attribute is a key, the same XML would parse to:
+
+ {
+ 'user' => {
+ 'stty' => {
+ 'fullname' => 'Simon T Tyson'
+ },
+ 'grep' => {
+ 'fullname' => 'Gary R Epstein'
+ }
+ }
+ }
+
+The key attribute names should be supplied in an arrayref if there is more
+than one. C will attempt to match attribute names in the order
+supplied. C will use the first attribute name supplied when
+'unfolding' a hash into an array.
+
+Note 1: The default value for 'KeyAttr' is ['name', 'key', 'id']. If you do
+not want folding on input or unfolding on output you must setting this option
+to an empty list to disable the feature.
+
+Note 2: If you wish to use this option, you should also enable the
+C option. Without 'ForceArray', a single nested element will be
+rolled up into a scalar rather than an array and therefore will not be folded
+(since only arrays get folded).
+
+=head2 KeyAttr => { list } I<# in+out - important>
+
+This alternative (and preferred) method of specifiying the key attributes
+allows more fine grained control over which elements are folded and on which
+attributes. For example the option 'KeyAttr => { package => 'id' } will cause
+any package elements to be folded on the 'id' attribute. No other elements
+which have an 'id' attribute will be folded at all.
+
+Note: C will generate a warning (or a fatal error in L<"STRICT MODE">)
+if this syntax is used and an element which does not have the specified key
+attribute is encountered (eg: a 'package' element without an 'id' attribute, to
+use the example above). Warnings will only be generated if B<-w> is in force.
+
+Two further variations are made possible by prefixing a '+' or a '-' character
+to the attribute name:
+
+The option 'KeyAttr => { user => "+login" }' will cause this XML:
+
+
+
+
+
+
+to parse to this data structure:
+
+ {
+ 'user' => {
+ 'stty' => {
+ 'fullname' => 'Simon T Tyson',
+ 'login' => 'stty'
+ },
+ 'grep' => {
+ 'fullname' => 'Gary R Epstein',
+ 'login' => 'grep'
+ }
+ }
+ }
+
+The '+' indicates that the value of the key attribute should be copied rather
+than moved to the folded hash key.
+
+A '-' prefix would produce this result:
+
+ {
+ 'user' => {
+ 'stty' => {
+ 'fullname' => 'Simon T Tyson',
+ '-login' => 'stty'
+ },
+ 'grep' => {
+ 'fullname' => 'Gary R Epstein',
+ '-login' => 'grep'
+ }
+ }
+ }
+
+As described earlier, C will ignore hash keys starting with a '-'.
+
+=head2 NoAttr => 1 I<# in+out - handy>
+
+When used with C, the generated XML will contain no attributes.
+All hash key/values will be represented as nested elements instead.
+
+When used with C, any attributes in the XML will be ignored.
+
+=head2 NoEscape => 1 I<# out - seldom used>
+
+By default, C will translate the characters 'E', 'E', '&' and
+'"' to '<', '>', '&' and '"' respectively. Use this option to
+suppress escaping (presumably because you've already escaped the data in some
+more sophisticated manner).
+
+=head2 NoIndent => 1 I<# out - seldom used>
+
+Set this option to 1 to disable C's default 'pretty printing' mode.
+With this option enabled, the XML output will all be on one line (unless there
+are newlines in the data) - this may be easier for downstream processing.
+
+=head2 NoSort => 1 I<# out - seldom used>
+
+Newer versions of XML::Simple sort elements and attributes alphabetically (*),
+by default. Enable this option to suppress the sorting - possibly for
+backwards compatibility.
+
+* Actually, sorting is alphabetical but 'key' attribute or element names (as in
+'KeyAttr') sort first. Also, when a hash of hashes is 'unfolded', the elements
+are sorted alphabetically by the value of the key field.
+
+=head2 NormaliseSpace => 0 | 1 | 2 I<# in - handy>
+
+This option controls how whitespace in text content is handled. Recognised
+values for the option are:
+
+=over 4
+
+=item *
+
+0 = (default) whitespace is passed through unaltered (except of course for the
+normalisation of whitespace in attribute values which is mandated by the XML
+recommendation)
+
+=item *
+
+1 = whitespace is normalised in any value used as a hash key (normalising means
+removing leading and trailing whitespace and collapsing sequences of whitespace
+characters to a single space)
+
+=item *
+
+2 = whitespace is normalised in all text content
+
+=back
+
+Note: you can spell this option with a 'z' if that is more natural for you.
+
+=head2 NSExpand => 1 I<# in+out handy - SAX only>
+
+This option controls namespace expansion - the translation of element and
+attribute names of the form 'prefix:name' to '{uri}name'. For example the
+element name 'xsl:template' might be expanded to:
+'{http://www.w3.org/1999/XSL/Transform}template'.
+
+By default, C will return element names and attribute names exactly as
+they appear in the XML. Setting this option to 1 will cause all element and
+attribute names to be expanded to include their namespace prefix.
+
+I.
+
+This option also controls whether C performs the reverse translation
+from '{uri}name' back to 'prefix:name'. The default is no translation. If
+your data contains expanded names, you should set this option to 1 otherwise
+C will emit XML which is not well formed.
+
+I to translate URIs back to prefixes>.
+
+=head2 NumericEscape => 0 | 1 | 2 I<# out - handy>
+
+Use this option to have 'high' (non-ASCII) characters in your Perl data
+structure converted to numeric entities (eg: €) in the XML output. Three
+levels are possible:
+
+0 - default: no numeric escaping (OK if you're writing out UTF8)
+
+1 - only characters above 0xFF are escaped (ie: characters in the 0x80-FF range are not escaped), possibly useful with ISO8859-1 output
+
+2 - all characters above 0x7F are escaped (good for plain ASCII output)
+
+=head2 OutputFile => I<# out - handy>
+
+The default behaviour of C is to return the XML as a string. If you
+wish to write the XML to a file, simply supply the filename using the
+'OutputFile' option.
+
+This option also accepts an IO handle object - especially useful in Perl 5.8.0
+and later for output using an encoding other than UTF-8, eg:
+
+ open my $fh, '>:encoding(iso-8859-1)', $path or die "open($path): $!";
+ XMLout($ref, OutputFile => $fh);
+
+Note, XML::Simple does not require that the object you pass in to the
+OutputFile option inherits from L - it simply assumes the object
+supports a C method.
+
+=head2 ParserOpts => [ XML::Parser Options ] I<# in - don't use this>
+
+I.
+
+This option allows you to pass parameters to the constructor of the underlying
+XML::Parser object (which of course assumes you're not using SAX).
+
+=head2 RootName => 'string' I<# out - handy>
+
+By default, when C generates XML, the root element will be named
+'opt'. This option allows you to specify an alternative name.
+
+Specifying either undef or the empty string for the RootName option will
+produce XML with no root elements. In most cases the resulting XML fragment
+will not be 'well formed' and therefore could not be read back in by C.
+Nevertheless, the option has been found to be useful in certain circumstances.
+
+=head2 SearchPath => [ list ] I<# in - handy>
+
+If you pass C a filename, but the filename include no directory
+component, you can use this option to specify which directories should be
+searched to locate the file. You might use this option to search first in the
+user's home directory, then in a global directory such as /etc.
+
+If a filename is provided to C but SearchPath is not defined, the
+file is assumed to be in the current directory.
+
+If the first parameter to C is undefined, the default SearchPath
+will contain only the directory in which the script itself is located.
+Otherwise the default SearchPath will be empty.
+
+=head2 SuppressEmpty => 1 | '' | undef I<# in+out - handy>
+
+This option controls what C should do with empty elements (no
+attributes and no content). The default behaviour is to represent them as
+empty hashes. Setting this option to a true value (eg: 1) will cause empty
+elements to be skipped altogether. Setting the option to 'undef' or the empty
+string will cause empty elements to be represented as the undefined value or
+the empty string respectively. The latter two alternatives are a little
+easier to test for in your code than a hash with no keys.
+
+The option also controls what C does with undefined values. Setting
+the option to undef causes undefined values to be output as empty elements
+(rather than empty attributes), it also suppresses the generation of warnings
+about undefined values. Setting the option to a true value (eg: 1) causes
+undefined values to be skipped altogether on output.
+
+=head2 ValueAttr => [ names ] I<# in - handy>
+
+Use this option to deal elements which always have a single attribute and no
+content. Eg:
+
+
+
+
+
+
+Setting C<< ValueAttr => [ 'value' ] >> will cause the above XML to parse to:
+
+ {
+ colour => 'red',
+ size => 'XXL'
+ }
+
+instead of this (the default):
+
+ {
+ colour => { value => 'red' },
+ size => { value => 'XXL' }
+ }
+
+Note: This form of the ValueAttr option is not compatible with C -
+since the attribute name is discarded at parse time, the original XML cannot be
+reconstructed.
+
+=head2 ValueAttr => { element => attribute, ... } I<# in+out - handy>
+
+This (preferred) form of the ValueAttr option requires you to specify both
+the element and the attribute names. This is not only safer, it also allows
+the original XML to be reconstructed by C.
+
+Note: You probably don't want to use this option and the NoAttr option at the
+same time.
+
+=head2 Variables => { name => value } I<# in - handy>
+
+This option allows variables in the XML to be expanded when the file is read.
+(there is no facility for putting the variable names back if you regenerate
+XML using C).
+
+A 'variable' is any text of the form C<${name}> which occurs in an attribute
+value or in the text content of an element. If 'name' matches a key in the
+supplied hashref, C<${name}> will be replaced with the corresponding value from
+the hashref. If no matching key is found, the variable will not be replaced.
+Names must match the regex: C<[\w.]+> (ie: only 'word' characters and dots are
+allowed).
+
+=head2 VarAttr => 'attr_name' I<# in - handy>
+
+In addition to the variables defined using C, this option allows
+variables to be defined in the XML. A variable definition consists of an
+element with an attribute called 'attr_name' (the value of the C
+option). The value of the attribute will be used as the variable name and the
+text content of the element will be used as the value. A variable defined in
+this way will override a variable defined using the C option. For
+example:
+
+ XMLin( '
+ /usr/local/apache
+ ${prefix}
+ ${exec_prefix}/bin
+ ',
+ VarAttr => 'name', ContentKey => '-content'
+ );
+
+produces the following data structure:
+
+ {
+ dir => {
+ prefix => '/usr/local/apache',
+ exec_prefix => '/usr/local/apache',
+ bindir => '/usr/local/apache/bin',
+ }
+ }
+
+=head2 XMLDecl => 1 or XMLDecl => 'string' I<# out - handy>
+
+If you want the output from C to start with the optional XML
+declaration, simply set the option to '1'. The default XML declaration is:
+
+
+
+If you want some other string (for example to declare an encoding value), set
+the value of this option to the complete string you require.
+
+
+=head1 OPTIONAL OO INTERFACE
+
+The procedural interface is both simple and convenient however there are a
+couple of reasons why you might prefer to use the object oriented (OO)
+interface:
+
+=over 4
+
+=item *
+
+to define a set of default values which should be used on all subsequent calls
+to C or C
+
+=item *
+
+to override methods in B to provide customised behaviour
+
+=back
+
+The default values for the options described above are unlikely to suit
+everyone. The OO interface allows you to effectively override B's
+defaults with your preferred values. It works like this:
+
+First create an XML::Simple parser object with your preferred defaults:
+
+ my $xs = XML::Simple->new(ForceArray => 1, KeepRoot => 1);
+
+then call C or C as a method of that object:
+
+ my $ref = $xs->XMLin($xml);
+ my $xml = $xs->XMLout($ref);
+
+You can also specify options when you make the method calls and these values
+will be merged with the values specified when the object was created. Values
+specified in a method call take precedence.
+
+Note: when called as methods, the C and C routines may be
+called as C or C. The method names are aliased so the
+only difference is the aesthetics.
+
+=head2 Parsing Methods
+
+You can explicitly call one of the following methods rather than rely on the
+C method automatically determining whether the target to be parsed is
+a string, a file or a filehandle:
+
+=over 4
+
+=item parse_string(text)
+
+Works exactly like the C method but assumes the first argument is
+a string of XML (or a reference to a scalar containing a string of XML).
+
+=item parse_file(filename)
+
+Works exactly like the C method but assumes the first argument is
+the name of a file containing XML.
+
+=item parse_fh(file_handle)
+
+Works exactly like the C method but assumes the first argument is
+a filehandle which can be read to get XML.
+
+=back
+
+=head2 Hook Methods
+
+You can make your own class which inherits from XML::Simple and overrides
+certain behaviours. The following methods may provide useful 'hooks' upon
+which to hang your modified behaviour. You may find other undocumented methods
+by examining the source, but those may be subject to change in future releases.
+
+=over 4
+
+=item handle_options(direction, name => value ...)
+
+This method will be called when one of the parsing methods or the C
+method is called. The initial argument will be a string (either 'in' or 'out')
+and the remaining arguments will be name value pairs.
+
+=item default_config_file()
+
+Calculates and returns the name of the file which should be parsed if no
+filename is passed to C (default: C<$0.xml>).
+
+=item build_simple_tree(filename, string)
+
+Called from C or any of the parsing methods. Takes either a file name
+as the first argument or C followed by a 'string' as the second
+argument. Returns a simple tree data structure. You could override this
+method to apply your own transformations before the data structure is returned
+to the caller.
+
+=item new_hashref()
+
+When the 'simple tree' data structure is being built, this method will be
+called to create any required anonymous hashrefs.
+
+=item sorted_keys(name, hashref)
+
+Called when C is translating a hashref to XML. This routine returns
+a list of hash keys in the order that the corresponding attributes/elements
+should appear in the output.
+
+=item escape_value(string)
+
+Called from C, takes a string and returns a copy of the string with
+XML character escaping rules applied.
+
+=item numeric_escape(string)
+
+Called from C, to handle non-ASCII characters (depending on the
+value of the NumericEscape option).
+
+=item copy_hash(hashref, extra_key => value, ...)
+
+Called from C, when 'unfolding' a hash of hashes into an array of
+hashes. You might wish to override this method if you're using tied hashes and
+don't want them to get untied.
+
+=back
+
+=head2 Cache Methods
+
+XML::Simple implements three caching schemes ('storable', 'memshare' and
+'memcopy'). You can implement a custom caching scheme by implementing
+two methods - one for reading from the cache and one for writing to it.
+
+For example, you might implement a new 'dbm' scheme that stores cached data
+structures using the L module. First, you would add a
+C method which accepted a filename for use as a lookup key
+and returned a data structure on success, or undef on failure. Then, you would
+implement a C method which accepted a data structure and a
+filename.
+
+You would use this caching scheme by specifying the option:
+
+ Cache => [ 'dbm' ]
+
+=head1 STRICT MODE
+
+If you import the B routines like this:
+
+ use XML::Simple qw(:strict);
+
+the following common mistakes will be detected and treated as fatal errors
+
+=over 4
+
+=item *
+
+Failing to explicitly set the C option - if you can't be bothered
+reading about this option, turn it off with: KeyAttr => [ ]
+
+=item *
+
+Failing to explicitly set the C option - if you can't be bothered
+reading about this option, set it to the safest mode with: ForceArray => 1
+
+=item *
+
+Setting ForceArray to an array, but failing to list all the elements from the
+KeyAttr hash.
+
+=item *
+
+Data error - KeyAttr is set to say { part => 'partnum' } but the XML contains
+one or more EpartE elements without a 'partnum' attribute (or nested
+element). Note: if strict mode is not set but -w is, this condition triggers a
+warning.
+
+=item *
+
+Data error - as above, but non-unique values are present in the key attribute
+(eg: more than one EpartE element with the same partnum). This will
+also trigger a warning if strict mode is not enabled.
+
+=item *
+
+Data error - as above, but value of key attribute (eg: partnum) is not a
+scalar string (due to nested elements etc). This will also trigger a warning
+if strict mode is not enabled.
+
+=back
+
+=head1 SAX SUPPORT
+
+From version 1.08_01, B includes support for SAX (the Simple API
+for XML) - specifically SAX2.
+
+In a typical SAX application, an XML parser (or SAX 'driver') module generates
+SAX events (start of element, character data, end of element, etc) as it parses
+an XML document and a 'handler' module processes the events to extract the
+required data. This simple model allows for some interesting and powerful
+possibilities:
+
+=over 4
+
+=item *
+
+Applications written to the SAX API can extract data from huge XML documents
+without the memory overheads of a DOM or tree API.
+
+=item *
+
+The SAX API allows for plug and play interchange of parser modules without
+having to change your code to fit a new module's API. A number of SAX parsers
+are available with capabilities ranging from extreme portability to blazing
+performance.
+
+=item *
+
+A SAX 'filter' module can implement both a handler interface for receiving
+data and a generator interface for passing modified data on to a downstream
+handler. Filters can be chained together in 'pipelines'.
+
+=item *
+
+One filter module might split a data stream to direct data to two or more
+downstream handlers.
+
+=item *
+
+Generating SAX events is not the exclusive preserve of XML parsing modules.
+For example, a module might extract data from a relational database using DBI
+and pass it on to a SAX pipeline for filtering and formatting.
+
+=back
+
+B can operate at either end of a SAX pipeline. For example,
+you can take a data structure in the form of a hashref and pass it into a
+SAX pipeline using the 'Handler' option on C:
+
+ use XML::Simple;
+ use Some::SAX::Filter;
+ use XML::SAX::Writer;
+
+ my $ref = {
+ .... # your data here
+ };
+
+ my $writer = XML::SAX::Writer->new();
+ my $filter = Some::SAX::Filter->new(Handler => $writer);
+ my $simple = XML::Simple->new(Handler => $filter);
+ $simple->XMLout($ref);
+
+You can also put B at the opposite end of the pipeline to take
+advantage of the simple 'tree' data structure once the relevant data has been
+isolated through filtering:
+
+ use XML::SAX;
+ use Some::SAX::Filter;
+ use XML::Simple;
+
+ my $simple = XML::Simple->new(ForceArray => 1, KeyAttr => ['partnum']);
+ my $filter = Some::SAX::Filter->new(Handler => $simple);
+ my $parser = XML::SAX::ParserFactory->parser(Handler => $filter);
+
+ my $ref = $parser->parse_uri('some_huge_file.xml');
+
+ print $ref->{part}->{'555-1234'};
+
+You can build a filter by using an XML::Simple object as a handler and setting
+its DataHandler option to point to a routine which takes the resulting tree,
+modifies it and sends it off as SAX events to a downstream handler:
+
+ my $writer = XML::SAX::Writer->new();
+ my $filter = XML::Simple->new(
+ DataHandler => sub {
+ my $simple = shift;
+ my $data = shift;
+
+ # Modify $data here
+
+ $simple->XMLout($data, Handler => $writer);
+ }
+ );
+ my $parser = XML::SAX::ParserFactory->parser(Handler => $filter);
+
+ $parser->parse_uri($filename);
+
+I but it could also have been specified in the constructor>.
+
+=head1 ENVIRONMENT
+
+If you don't care which parser module B uses then skip this
+section entirely (it looks more complicated than it really is).
+
+B will default to using a B parser if one is available or
+B if SAX is not available.
+
+You can dictate which parser module is used by setting either the environment
+variable 'XML_SIMPLE_PREFERRED_PARSER' or the package variable
+$XML::Simple::PREFERRED_PARSER to contain the module name. The following rules
+are used:
+
+=over 4
+
+=item *
+
+The package variable takes precedence over the environment variable if both are defined. To force B to ignore the environment settings and use
+its default rules, you can set the package variable to an empty string.
+
+=item *
+
+If the 'preferred parser' is set to the string 'XML::Parser', then
+L will be used (or C will die if L is not
+installed).
+
+=item *
+
+If the 'preferred parser' is set to some other value, then it is assumed to be
+the name of a SAX parser module and is passed to L
+If L is not installed, or the requested parser module is not
+installed, then C will die.
+
+=item *
+
+If the 'preferred parser' is not defined at all (the normal default
+state), an attempt will be made to load L. If L is
+installed, then a parser module will be selected according to
+L's normal rules (which typically means the last SAX
+parser installed).
+
+=item *
+
+if the 'preferred parser' is not defined and B is not
+installed, then B will be used. C will die if
+L is not installed.
+
+=back
+
+Note: The B distribution includes an XML parser written entirely in
+Perl. It is very portable but it is not very fast. You should consider
+installing L or L if they are available for your
+platform.
+
+=head1 ERROR HANDLING
+
+The XML standard is very clear on the issue of non-compliant documents. An
+error in parsing any single element (for example a missing end tag) must cause
+the whole document to be rejected. B will die with an appropriate
+message if it encounters a parsing error.
+
+If dying is not appropriate for your application, you should arrange to call
+C in an eval block and look for errors in $@. eg:
+
+ my $config = eval { XMLin() };
+ PopUpMessage($@) if($@);
+
+Note, there is a common misconception that use of B will significantly
+slow down a script. While that may be true when the code being eval'd is in a
+string, it is not true of code like the sample above.
+
+=head1 EXAMPLES
+
+When C reads the following very simple piece of XML:
+
+
+
+it returns the following data structure:
+
+ {
+ 'username' => 'testuser',
+ 'password' => 'frodo'
+ }
+
+The identical result could have been produced with this alternative XML:
+
+
+
+Or this (although see 'ForceArray' option for variations):
+
+
+ testuser
+ frodo
+
+
+Repeated nested elements are represented as anonymous arrays:
+
+
+
+ joe@smith.com
+ jsmith@yahoo.com
+
+
+ bob@smith.com
+
+
+
+ {
+ 'person' => [
+ {
+ 'email' => [
+ 'joe@smith.com',
+ 'jsmith@yahoo.com'
+ ],
+ 'firstname' => 'Joe',
+ 'lastname' => 'Smith'
+ },
+ {
+ 'email' => 'bob@smith.com',
+ 'firstname' => 'Bob',
+ 'lastname' => 'Smith'
+ }
+ ]
+ }
+
+Nested elements with a recognised key attribute are transformed (folded) from
+an array into a hash keyed on the value of that attribute (see the C
+option):
+
+
+
+
+
+
+
+ {
+ 'person' => {
+ 'jbloggs' => {
+ 'firstname' => 'Joe',
+ 'lastname' => 'Bloggs'
+ },
+ 'tsmith' => {
+ 'firstname' => 'Tom',
+ 'lastname' => 'Smith'
+ },
+ 'jsmith' => {
+ 'firstname' => 'Joe',
+ 'lastname' => 'Smith'
+ }
+ }
+ }
+
+
+The tag can be used to form anonymous arrays:
+
+
+ Col 1Col 2Col 3
+ R1C1R1C2R1C3
+ R2C1R2C2R2C3
+ R3C1R3C2R3C3
+
+
+ {
+ 'head' => [
+ [ 'Col 1', 'Col 2', 'Col 3' ]
+ ],
+ 'data' => [
+ [ 'R1C1', 'R1C2', 'R1C3' ],
+ [ 'R2C1', 'R2C2', 'R2C3' ],
+ [ 'R3C1', 'R3C2', 'R3C3' ]
+ ]
+ }
+
+Anonymous arrays can be nested to arbirtrary levels and as a special case, if
+the surrounding tags for an XML document contain only an anonymous array the
+arrayref will be returned directly rather than the usual hashref:
+
+
+ Col 1Col 2
+ R1C1R1C2
+ R2C1R2C2
+
+
+ [
+ [ 'Col 1', 'Col 2' ],
+ [ 'R1C1', 'R1C2' ],
+ [ 'R2C1', 'R2C2' ]
+ ]
+
+Elements which only contain text content will simply be represented as a
+scalar. Where an element has both attributes and text content, the element
+will be represented as a hashref with the text content in the 'content' key
+(see the C option):
+
+
+ first
+ second
+
+
+ {
+ 'one' => 'first',
+ 'two' => { 'attr' => 'value', 'content' => 'second' }
+ }
+
+Mixed content (elements which contain both text content and nested elements)
+will be not be represented in a useful way - element order and significant
+whitespace will be lost. If you need to work with mixed content, then
+XML::Simple is not the right tool for your job - check out the next section.
+
+=head1 WHERE TO FROM HERE?
+
+B is able to present a simple API because it makes some
+assumptions on your behalf. These include:
+
+=over 4
+
+=item *
+
+You're not interested in text content consisting only of whitespace
+
+=item *
+
+You don't mind that when things get slurped into a hash the order is lost
+
+=item *
+
+You don't want fine-grained control of the formatting of generated XML
+
+=item *
+
+You would never use a hash key that was not a legal XML element name
+
+=item *
+
+You don't need help converting between different encodings
+
+=back
+
+In a serious XML project, you'll probably outgrow these assumptions fairly
+quickly. This section of the document used to offer some advice on chosing a
+more powerful option. That advice has now grown into the 'Perl-XML FAQ'
+document which you can find at: L
+
+The advice in the FAQ boils down to a quick explanation of tree versus
+event based parsers and then recommends:
+
+For event based parsing, use SAX (do not set out to write any new code for
+XML::Parser's handler API - it is obselete).
+
+For tree-based parsing, you could choose between the 'Perlish' approach of
+L and more standards based DOM implementations - preferably one with
+XPath support.
+
+
+=head1 SEE ALSO
+
+B requires either L or L.
+
+To generate documents with namespaces, L is required.
+
+The optional caching functions require L.
+
+Answers to Frequently Asked Questions about XML::Simple are bundled with this
+distribution as: L
+
+=head1 COPYRIGHT
+
+Copyright 1999-2004 Grant McLean Egrantm@cpan.orgE
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+
diff --git a/share/perl/lib/XML/TreePP.pm b/share/perl/lib/XML/TreePP.pm
new file mode 100644
index 0000000..bd03db7
--- /dev/null
+++ b/share/perl/lib/XML/TreePP.pm
@@ -0,0 +1,1228 @@
+=head1 NAME
+
+XML::TreePP -- Pure Perl implementation for parsing/writing xml files
+
+=head1 SYNOPSIS
+
+parse xml file into hash tree
+
+ use XML::TreePP;
+ my $tpp = XML::TreePP->new();
+ my $tree = $tpp->parsefile( "index.rdf" );
+ print "Title: ", $tree->{"rdf:RDF"}->{item}->[0]->{title}, "\n";
+ print "URL: ", $tree->{"rdf:RDF"}->{item}->[0]->{link}, "\n";
+
+write xml as string from hash tree
+
+ use XML::TreePP;
+ my $tpp = XML::TreePP->new();
+ my $tree = { rss => { channel => { item => [ {
+ title => "The Perl Directory",
+ link => "http://www.perl.org/",
+ }, {
+ title => "The Comprehensive Perl Archive Network",
+ link => "http://cpan.perl.org/",
+ } ] } } };
+ my $xml = $tpp->write( $tree );
+ print $xml;
+
+get remote xml file with HTTP-GET and parse it into hash tree
+
+ use XML::TreePP;
+ my $tpp = XML::TreePP->new();
+ my $tree = $tpp->parsehttp( GET => "http://use.perl.org/index.rss" );
+ print "Title: ", $tree->{"rdf:RDF"}->{channel}->{title}, "\n";
+ print "URL: ", $tree->{"rdf:RDF"}->{channel}->{link}, "\n";
+
+get remote xml file with HTTP-POST and parse it into hash tree
+
+ use XML::TreePP;
+ my $tpp = XML::TreePP->new( force_array => [qw( item )] );
+ my $cgiurl = "http://search.hatena.ne.jp/keyword";
+ my $keyword = "ajax";
+ my $cgiquery = "mode=rss2&word=".$keyword;
+ my $tree = $tpp->parsehttp( POST => $cgiurl, $cgiquery );
+ print "Link: ", $tree->{rss}->{channel}->{item}->[0]->{link}, "\n";
+ print "Desc: ", $tree->{rss}->{channel}->{item}->[0]->{description}, "\n";
+
+=head1 DESCRIPTION
+
+XML::TreePP module parses XML file and expands it for a hash tree.
+And also generate XML file from a hash tree.
+This is a pure Perl implementation.
+You can also download XML from remote web server
+like XMLHttpRequest object at JavaScript language.
+
+=head1 EXAMPLES
+
+=head2 Parse XML file
+
+Sample XML source:
+
+
+
+ Yasuhisa
+ Chizuko
+
+ Shiori
+ Yusuke
+ Kairi
+
+
+
+Sample program to read a xml file and dump it:
+
+ use XML::TreePP;
+ use Data::Dumper;
+ my $tpp = XML::TreePP->new();
+ my $tree = $tpp->parsefile( "family.xml" );
+ my $text = Dumper( $tree );
+ print $text;
+
+Result dumped:
+
+ $VAR1 = {
+ 'family' => {
+ '-name' => 'Kawasaki',
+ 'father' => 'Yasuhisa',
+ 'mother' => 'Chizuko',
+ 'children' => {
+ 'girl' => 'Shiori'
+ 'boy' => [
+ 'Yusuke',
+ 'Kairi'
+ ],
+ }
+ }
+ };
+
+Details:
+
+ print $tree->{family}->{father}; # the father's given name.
+
+The prefix '-' is added on every attribute's name.
+
+ print $tree->{family}->{"-name"}; # the family name of the family
+
+The array is used because the family has two boys.
+
+ print $tree->{family}->{children}->{boy}->[1]; # The second boy's name
+ print $tree->{family}->{children}->{girl}; # The girl's name
+
+=head2 Text node and attributes:
+
+If a element has both of a text node and attributes
+or both of a text node and other child nodes,
+value of a text node is moved to C<#text> like child nodes.
+
+ use XML::TreePP;
+ use Data::Dumper;
+ my $tpp = XML::TreePP->new();
+ my $source = 'Kawasaki Yusuke';
+ my $tree = $tpp->parse( $source );
+ my $text = Dumper( $tree );
+ print $text;
+
+The result dumped is following:
+
+ $VAR1 = {
+ 'span' => {
+ '-class' => 'author',
+ '#text' => 'Kawasaki Yusuke'
+ }
+ };
+
+The special node name of C<#text> is used because this elements
+has attribute(s) in addition to the text node.
+See also L option.
+
+=head1 METHODS
+
+=head2 new
+
+This constructor method returns a new XML::TreePP object with C<%options>.
+
+ $tpp = XML::TreePP->new( %options );
+
+=head2 set
+
+This method sets a option value for C.
+If C<$option_value> is not defined, its option is deleted.
+
+ $tpp->set( option_name => $option_value );
+
+See OPTIONS section below for details.
+
+=head2 get
+
+This method returns a current option value for C.
+
+ $tpp->get( 'option_name' );
+
+=head2 parse
+
+This method reads XML source and returns a hash tree converted.
+The first argument is a scalar or a reference to a scalar.
+
+ $tree = $tpp->parse( $source );
+
+=head2 parsefile
+
+This method reads a XML file and returns a hash tree converted.
+The first argument is a filename.
+
+ $tree = $tpp->parsefile( $file );
+
+=head2 parsehttp
+
+This method receives a XML file from a remote server via HTTP and
+returns a hash tree converted.
+
+ $tree = $tpp->parsehttp( $method, $url, $body, $head );
+
+C<$method> is a method of HTTP connection: GET/POST/PUT/DELETE
+C<$url> is an URI of a XML file.
+C<$body> is a request body when you use POST method.
+C<$head> is a request headers as a hash ref.
+L module or L module is required to fetch a file.
+
+ ( $tree, $xml, $code ) = $tpp->parsehttp( $method, $url, $body, $head );
+
+In array context, This method returns also raw XML source received
+and HTTP response's status code.
+
+=head2 write
+
+This method parses a hash tree and returns a XML source generated.
+
+ $source = $tpp->write( $tree, $encode );
+
+C<$tree> is a reference to a hash tree.
+
+=head2 writefile
+
+This method parses a hash tree and writes a XML source into a file.
+
+ $tpp->writefile( $file, $tree, $encode );
+
+C<$file> is a filename to create.
+C<$tree> is a reference to a hash tree.
+
+=head1 OPTIONS FOR PARSING XML
+
+This module accepts option parameters following:
+
+=head2 force_array
+
+This option allows you to specify a list of element names which
+should always be forced into an array representation.
+
+ $tpp->set( force_array => [ 'rdf:li', 'item', '-xmlns' ] );
+
+The default value is null, it means that context of the elements
+will determine to make array or to keep it scalar or hash.
+Note that the special wildcard name C<'*'> means all elements.
+
+=head2 force_hash
+
+This option allows you to specify a list of element names which
+should always be forced into an hash representation.
+
+ $tpp->set( force_hash => [ 'item', 'image' ] );
+
+The default value is null, it means that context of the elements
+will determine to make hash or to keep it scalar as a text node.
+See also L option below.
+Note that the special wildcard name C<'*'> means all elements.
+
+=head2 cdata_scalar_ref
+
+This option allows you to convert a cdata section into a reference
+for scalar on parsing XML source.
+
+ $tpp->set( cdata_scalar_ref => 1 );
+
+The default value is false, it means that each cdata section is converted into a scalar.
+
+=head2 user_agent
+
+This option allows you to specify a HTTP_USER_AGENT string which
+is used by parsehttp() method.
+
+ $tpp->set( user_agent => 'Mozilla/4.0 (compatible; ...)' );
+
+The default string is C<'XML-TreePP/#.##'>, where C<'#.##'> is
+substituted with the version number of this library.
+
+=head2 http_lite
+
+This option forces pasrsehttp() method to use a L instance.
+
+ my $http = HTTP::Lite->new();
+ $tpp->set( http_lite => $http );
+
+=head2 lwp_useragent
+
+This option forces pasrsehttp() method to use a L instance.
+
+ my $ua = LWP::UserAgent->new();
+ $ua->timeout( 60 );
+ $ua->env_proxy;
+ $tpp->set( lwp_useragent => $ua );
+
+You may use this with L.
+
+=head2 base_class
+
+This blesses class name for each element's hashref.
+Each class is named straight as a child class of it parent class.
+
+ $tpp->set( base_class => 'MyElement' );
+ my $xml = 'text';
+ my $tree = $tpp->parse( $xml );
+ print ref $tree->{root}->{parent}->{child}, "\n";
+
+A hash for element above is blessed to C
+class. You may use this with L.
+
+=head2 elem_class
+
+This blesses class name for each element's hashref.
+Each class is named horizontally under the direct child of C.
+
+ $tpp->set( base_class => 'MyElement' );
+ my $xml = 'text';
+ my $tree = $tpp->parse( $xml );
+ print ref $tree->{root}->{parent}->{child}, "\n";
+
+A hash for element above is blessed to C class.
+
+=head1 OPTIONS FOR WRITING XML
+
+=head2 first_out
+
+This option allows you to specify a list of element/attribute
+names which should always appears at first on output XML code.
+
+ $tpp->set( first_out => [ 'link', 'title', '-type' ] );
+
+The default value is null, it means alphabetical order is used.
+
+=head2 last_out
+
+This option allows you to specify a list of element/attribute
+names which should always appears at last on output XML code.
+
+ $tpp->set( last_out => [ 'items', 'item', 'entry' ] );
+
+=head2 indent
+
+This makes the output more human readable by indenting appropriately.
+
+ $tpp->set( indent => 2 );
+
+This doesn't strictly follow the XML Document Spec but does looks nice.
+
+=head2 xml_decl
+
+This module generates an XML declaration on writing an XML code per default.
+This option forces to change or leave it.
+
+ $tpp->set( xml_decl => '' );
+
+=head2 output_encoding
+
+This option allows you to specify a encoding of xml file generated
+by write/writefile methods.
+
+ $tpp->set( output_encoding => 'UTF-8' );
+
+On Perl 5.8.0 and later, you can select it from every
+encodings supported by Encode.pm. On Perl 5.6.x and before with
+Jcode.pm, you can use C, C, C and
+C. The default value is C which is recommended encoding.
+
+=head1 OPTIONS FOR BOTH
+
+=head2 utf8_flag
+
+This makes utf8 flag on for every element's value parsed
+and makes it on for an XML code generated as well.
+
+ $tpp->set( utf8_flag => 1 );
+
+Perl 5.8.1 or later is required to use this.
+
+=head2 attr_prefix
+
+This option allows you to specify a prefix character(s) which
+is inserted before each attribute names.
+
+ $tpp->set( attr_prefix => '@' );
+
+The default character is C<'-'>.
+Or set C<'@'> to access attribute values like E4X, ECMAScript for XML.
+Zero-length prefix C<''> is available as well, it means no prefix is added.
+
+=head2 text_node_key
+
+This option allows you to specify a hash key for text nodes.
+
+ $tpp->set( text_node_key => '#text' );
+
+The default key is C<#text>.
+
+=head2 ignore_error
+
+This module calls Carp::croak function on an error per default.
+This option makes all errors ignored and just return.
+
+ $tpp->set( ignore_error => 1 );
+
+=head2 use_ixhash
+
+This option keeps the order for each element appeared in XML.
+L module is required.
+
+ $tpp->set( use_ixhash => 1 );
+
+This makes parsing performance slow.
+(about 100% slower than default)
+
+=head1 AUTHOR
+
+Yusuke Kawasaki, http://www.kawa.net/
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2006-2007 Yusuke Kawasaki. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+package XML::TreePP;
+use strict;
+use Carp;
+use Symbol;
+
+use vars qw( $VERSION );
+$VERSION = '0.32';
+
+my $XML_ENCODING = 'UTF-8';
+my $INTERNAL_ENCODING = 'UTF-8';
+my $USER_AGENT = 'XML-TreePP/'.$VERSION.' ';
+my $ATTR_PREFIX = '-';
+my $TEXT_NODE_KEY = '#text';
+
+sub new {
+ my $package = shift;
+ my $self = {@_};
+ bless $self, $package;
+ $self;
+}
+
+sub die {
+ my $self = shift;
+ my $mess = shift;
+ return if $self->{ignore_error};
+ Carp::croak $mess;
+}
+
+sub warn {
+ my $self = shift;
+ my $mess = shift;
+ return if $self->{ignore_error};
+ Carp::carp $mess;
+}
+
+sub set {
+ my $self = shift;
+ my $key = shift;
+ my $val = shift;
+ if ( defined $val ) {
+ $self->{$key} = $val;
+ }
+ else {
+ delete $self->{$key};
+ }
+}
+
+sub get {
+ my $self = shift;
+ my $key = shift;
+ $self->{$key} if exists $self->{$key};
+}
+
+sub writefile {
+ my $self = shift;
+ my $file = shift;
+ my $tree = shift or return $self->die( 'Invalid tree' );
+ my $encode = shift;
+ return $self->die( 'Invalid filename' ) unless defined $file;
+ my $text = $self->write( $tree, $encode );
+ if ( $] >= 5.008001 && utf8::is_utf8( $text ) ) {
+ utf8::encode( $text );
+ }
+ $self->write_raw_xml( $file, $text );
+}
+
+sub write {
+ my $self = shift;
+ my $tree = shift or return $self->die( 'Invalid tree' );
+ my $from = $self->{internal_encoding} || $INTERNAL_ENCODING;
+ my $to = shift || $self->{output_encoding} || $XML_ENCODING;
+ my $decl = $self->{xml_decl};
+ $decl = '' unless defined $decl;
+
+ local $self->{__first_out};
+ if ( exists $self->{first_out} ) {
+ my $keys = $self->{first_out};
+ $keys = [$keys] unless ref $keys;
+ $self->{__first_out} = { map { $keys->[$_] => $_ } 0 .. $#$keys };
+ }
+
+ local $self->{__last_out};
+ if ( exists $self->{last_out} ) {
+ my $keys = $self->{last_out};
+ $keys = [$keys] unless ref $keys;
+ $self->{__last_out} = { map { $keys->[$_] => $_ } 0 .. $#$keys };
+ }
+
+ my $tnk = $self->{text_node_key} if exists $self->{text_node_key};
+ $tnk = $TEXT_NODE_KEY unless defined $tnk;
+ local $self->{text_node_key} = $tnk;
+
+ my $apre = $self->{attr_prefix} if exists $self->{attr_prefix};
+ $apre = $ATTR_PREFIX unless defined $apre;
+ local $self->{__attr_prefix_len} = length($apre);
+ local $self->{__attr_prefix_rex} = defined $apre ? qr/^\Q$apre\E/s : undef;
+
+ local $self->{__indent};
+ if ( exists $self->{indent} && $self->{indent} ) {
+ $self->{__indent} = ' ' x $self->{indent};
+ }
+
+ my $text = $self->hash_to_xml( undef, $tree );
+ if ( $from && $to ) {
+ my $stat = $self->encode_from_to( \$text, $from, $to );
+ return $self->die( "Unsupported encoding: $to" ) unless $stat;
+ }
+
+ return $text if ( $decl eq '' );
+ join( "\n", $decl, $text );
+}
+
+sub parsehttp {
+ my $self = shift;
+
+ local $self->{__user_agent};
+ if ( exists $self->{user_agent} ) {
+ my $agent = $self->{user_agent};
+ $agent .= $USER_AGENT if ( $agent =~ /\s$/s );
+ $self->{__user_agent} = $agent if ( $agent ne '' );
+ } else {
+ $self->{__user_agent} = $USER_AGENT;
+ }
+
+ my $http = $self->{__http_module};
+ unless ( $http ) {
+ $http = $self->find_http_module(@_);
+ $self->{__http_module} = $http;
+ }
+ if ( $http eq 'LWP::UserAgent' ) {
+ return $self->parsehttp_lwp(@_);
+ }
+ elsif ( $http eq 'HTTP::Lite' ) {
+ return $self->parsehttp_lite(@_);
+ }
+ else {
+ return $self->die( "LWP::UserAgent or HTTP::Lite is required: $_[1]" );
+ }
+}
+
+sub find_http_module {
+ my $self = shift || {};
+
+ if ( exists $self->{lwp_useragent} && ref $self->{lwp_useragent} ) {
+ return 'LWP::UserAgent' if defined $LWP::UserAgent::VERSION;
+ return 'LWP::UserAgent' if &load_lwp_useragent();
+ return $self->die( "LWP::UserAgent is required: $_[1]" );
+ }
+
+ if ( exists $self->{http_lite} && ref $self->{http_lite} ) {
+ return 'HTTP::Lite' if defined $HTTP::Lite::VERSION;
+ return 'HTTP::Lite' if &load_http_lite();
+ return $self->die( "HTTP::Lite is required: $_[1]" );
+ }
+
+ return 'LWP::UserAgent' if defined $LWP::UserAgent::VERSION;
+ return 'HTTP::Lite' if defined $HTTP::Lite::VERSION;
+ return 'LWP::UserAgent' if &load_lwp_useragent();
+ return 'HTTP::Lite' if &load_http_lite();
+ return $self->die( "LWP::UserAgent or HTTP::Lite is required: $_[1]" );
+}
+
+sub load_lwp_useragent {
+ return $LWP::UserAgent::VERSION if defined $LWP::UserAgent::VERSION;
+ local $@;
+ eval { require LWP::UserAgent; };
+ $LWP::UserAgent::VERSION;
+}
+
+sub load_http_lite {
+ return $HTTP::Lite::VERSION if defined $HTTP::Lite::VERSION;
+ local $@;
+ eval { require HTTP::Lite; };
+ $HTTP::Lite::VERSION;
+}
+
+sub load_tie_ixhash {
+ return $Tie::IxHash::VERSION if defined $Tie::IxHash::VERSION;
+ local $@;
+ eval { require Tie::IxHash; };
+ $Tie::IxHash::VERSION;
+}
+
+sub parsehttp_lwp {
+ my $self = shift;
+ my $method = shift or return $self->die( 'Invalid HTTP method' );
+ my $url = shift or return $self->die( 'Invalid URL' );
+ my $body = shift;
+ my $header = shift;
+
+ my $ua = $self->{lwp_useragent} if exists $self->{lwp_useragent};
+ if ( ! ref $ua ) {
+ $ua = LWP::UserAgent->new();
+ $ua->timeout(10);
+ $ua->env_proxy();
+ $ua->agent( $self->{__user_agent} ) if defined $self->{__user_agent};
+ } else {
+ $ua->agent( $self->{__user_agent} ) if exists $self->{user_agent};
+ }
+
+ my $req = HTTP::Request->new( $method, $url );
+ my $ct = 0;
+ if ( ref $header ) {
+ foreach my $field ( sort keys %$header ) {
+ my $value = $header->{$field};
+ $req->header( $field => $value );
+ $ct ++ if ( $field =~ /^Content-Type$/i );
+ }
+ }
+ if ( defined $body && ! $ct ) {
+ $req->header( 'Content-Type' => 'application/x-www-form-urlencoded' );
+ }
+ $req->content($body) if defined $body;
+ my $res = $ua->request($req);
+ my $code = $res->code();
+ my $text = $res->content();
+ my $tree = $self->parse( \$text ) if $res->is_success();
+ wantarray ? ( $tree, $text, $code ) : $tree;
+}
+
+sub parsehttp_lite {
+ my $self = shift;
+ my $method = shift or return $self->die( 'Invalid HTTP method' );
+ my $url = shift or return $self->die( 'Invalid URL' );
+ my $body = shift;
+ my $header = shift;
+
+ my $http = HTTP::Lite->new();
+ $http->method($method);
+ my $ua = 0;
+ if ( ref $header ) {
+ foreach my $field ( sort keys %$header ) {
+ my $value = $header->{$field};
+ $http->add_req_header( $field, $value );
+ $ua ++ if ( $field =~ /^User-Agent$/i );
+ }
+ }
+ if ( defined $self->{__user_agent} && ! $ua ) {
+ $http->add_req_header( 'User-Agent', $self->{__user_agent} );
+ }
+ $http->{content} = $body if defined $body;
+ my $code = $http->request($url) or return;
+ my $text = $http->body();
+ my $tree = $self->parse( \$text );
+ wantarray ? ( $tree, $text, $code ) : $tree;
+}
+
+sub parsefile {
+ my $self = shift;
+ my $file = shift;
+ return $self->die( 'Invalid filename' ) unless defined $file;
+ my $text = $self->read_raw_xml($file);
+ $self->parse( \$text );
+}
+
+sub parse {
+ my $self = shift;
+ my $text = ref $_[0] ? ${$_[0]} : $_[0];
+ return $self->die( 'Null XML source' ) unless defined $text;
+
+ my $from = &xml_decl_encoding(\$text) || $XML_ENCODING;
+ my $to = $self->{internal_encoding} || $INTERNAL_ENCODING;
+ if ( $from && $to ) {
+ my $stat = $self->encode_from_to( \$text, $from, $to );
+ return $self->die( "Unsupported encoding: $from" ) unless $stat;
+ }
+
+ local $self->{__force_array};
+ local $self->{__force_array_all};
+ if ( exists $self->{force_array} ) {
+ my $force = $self->{force_array};
+ $force = [$force] unless ref $force;
+ $self->{__force_array} = { map { $_ => 1 } @$force };
+ $self->{__force_array_all} = $self->{__force_array}->{'*'};
+ }
+
+ local $self->{__force_hash};
+ local $self->{__force_hash_all};
+ if ( exists $self->{force_hash} ) {
+ my $force = $self->{force_hash};
+ $force = [$force] unless ref $force;
+ $self->{__force_hash} = { map { $_ => 1 } @$force };
+ $self->{__force_hash_all} = $self->{__force_hash}->{'*'};
+ }
+
+ my $tnk = $self->{text_node_key} if exists $self->{text_node_key};
+ $tnk = $TEXT_NODE_KEY unless defined $tnk;
+ local $self->{text_node_key} = $tnk;
+
+ my $apre = $self->{attr_prefix} if exists $self->{attr_prefix};
+ $apre = $ATTR_PREFIX unless defined $apre;
+ local $self->{attr_prefix} = $apre;
+
+ if ( exists $self->{use_ixhash} && $self->{use_ixhash} ) {
+ return $self->die( "Tie::IxHash is required." ) unless &load_tie_ixhash();
+ }
+
+ my $flat = $self->xml_to_flat(\$text);
+ my $class = $self->{base_class} if exists $self->{base_class};
+ my $tree = $self->flat_to_tree( $flat, '', $class );
+ if ( ref $tree ) {
+ if ( defined $class ) {
+ bless( $tree, $class );
+ }
+ elsif ( exists $self->{elem_class} && $self->{elem_class} ) {
+ bless( $tree, $self->{elem_class} );
+ }
+ }
+ wantarray ? ( $tree, $text ) : $tree;
+}
+
+sub xml_to_flat {
+ my $self = shift;
+ my $textref = shift; # reference
+ my $flat = [];
+ my $prefix = $self->{attr_prefix};
+ my $ixhash = ( exists $self->{use_ixhash} && $self->{use_ixhash} );
+
+ while ( $$textref =~ m{
+ ([^<]*) <
+ ((
+ \? ([^<>]*) \?
+ )|(
+ \!\[CDATA\[(.*?)\]\]
+ )|(
+ \!DOCTYPE\s+([^\[\]<>]*(?:\[.*?\]\s*)?)
+ )|(
+ \!--(.*?)--
+ )|(
+ ([^\!\?\s<>](?:"[^"]*"|'[^']*'|[^"'<>])*)
+ ))
+ > ([^<]*)
+ }sxg ) {
+ my (
+ $ahead, $match, $typePI, $contPI, $typeCDATA,
+ $contCDATA, $typeDocT, $contDocT, $typeCmnt, $contCmnt,
+ $typeElem, $contElem, $follow
+ )
+ = ( $1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13 );
+ if ( defined $ahead && $ahead =~ /\S/ ) {
+ $self->warn( "Invalid string: [$ahead] before <$match>" );
+ }
+
+ if ($typeElem) { # Element
+ my $node = {};
+ if ( $contElem =~ s#^/## ) {
+ $node->{endTag}++;
+ }
+ elsif ( $contElem =~ s#/$## ) {
+ $node->{emptyTag}++;
+ }
+ else {
+ $node->{startTag}++;
+ }
+ $node->{tagName} = $1 if ( $contElem =~ s#^(\S+)\s*## );
+ unless ( $node->{endTag} ) {
+ my $attr;
+ while ( $contElem =~ m{
+ ([^\s\=\"\']+)=(?:(")(.*?)"|'(.*?)')
+ }sxg ) {
+ my $key = $1;
+ my $val = &xml_unescape( $2 ? $3 : $4 );
+ if ( ! ref $attr ) {
+ $attr = {};
+ tie( %$attr, 'Tie::IxHash' ) if $ixhash;
+ }
+ $attr->{$prefix.$key} = $val;
+ }
+ $node->{attributes} = $attr if ref $attr;
+ }
+ push( @$flat, $node );
+ }
+ elsif ($typeCDATA) { ## CDATASection
+ if ( exists $self->{cdata_scalar_ref} && $self->{cdata_scalar_ref} ) {
+ push( @$flat, \$contCDATA ); # as reference for scalar
+ }
+ else {
+ push( @$flat, $contCDATA ); # as scalar like text node
+ }
+ }
+ elsif ($typeCmnt) { # Comment (ignore)
+ }
+ elsif ($typeDocT) { # DocumentType (ignore)
+ }
+ elsif ($typePI) { # ProcessingInstruction (ignore)
+ }
+ else {
+ $self->warn( "Invalid Tag: <$match>" );
+ }
+ if ( $follow =~ /\S/ ) { # text node
+ my $val = &xml_unescape($follow);
+ push( @$flat, $val );
+ }
+ }
+ $flat;
+}
+
+sub flat_to_tree {
+ my $self = shift;
+ my $source = shift;
+ my $parent = shift;
+ my $class = shift;
+ my $tree = {};
+ my $text = [];
+
+ if ( exists $self->{use_ixhash} && $self->{use_ixhash} ) {
+ tie( %$tree, 'Tie::IxHash' );
+ }
+
+ while ( scalar @$source ) {
+ my $node = shift @$source;
+ if ( !ref $node || UNIVERSAL::isa( $node, "SCALAR" ) ) {
+ push( @$text, $node ); # cdata or text node
+ next;
+ }
+ my $name = $node->{tagName};
+ if ( $node->{endTag} ) {
+ last if ( $parent eq $name );
+ return $self->die( "Invalid tag sequence: <$parent>" );
+ }
+ my $elem = $node->{attributes};
+ my $forcehash = $self->{__force_hash_all} || $self->{__force_hash}->{$name};
+ my $subclass;
+ if ( defined $class ) {
+ my $escname = $name;
+ $escname =~ s/\W/_/sg;
+ $subclass = $class.'::'.$escname;
+ }
+ if ( $node->{startTag} ) { # recursive call
+ my $child = $self->flat_to_tree( $source, $name, $subclass );
+ next unless defined $child;
+ my $hasattr = scalar keys %$elem if ref $elem;
+ if ( UNIVERSAL::isa( $child, "HASH" ) ) {
+ if ( $hasattr ) {
+ # some attributes and some child nodes
+ %$elem = ( %$elem, %$child );
+ }
+ else {
+ # some child nodes without attributes
+ $elem = $child;
+ }
+ }
+ else {
+ if ( $hasattr ) {
+ # some attributes and text node
+ $elem->{$self->{text_node_key}} = $child;
+ }
+ elsif ( $forcehash ) {
+ # only text node without attributes
+ $elem = { $self->{text_node_key} => $child };
+ }
+ else {
+ # text node without attributes
+ $elem = $child;
+ }
+ }
+ }
+ elsif ( $forcehash && ! ref $elem ) {
+ $elem = {};
+ }
+ # bless to a class by base_class or elem_class
+ if ( ref $elem && UNIVERSAL::isa( $elem, "HASH" ) ) {
+ if ( defined $subclass ) {
+ bless( $elem, $subclass );
+ } elsif ( exists $self->{elem_class} && $self->{elem_class} ) {
+ my $escname = $name;
+ $escname =~ s/\W/_/sg;
+ my $elmclass = $self->{elem_class}.'::'.$escname;
+ bless( $elem, $elmclass );
+ }
+ }
+ # next unless defined $elem;
+ $tree->{$name} ||= [];
+ push( @{ $tree->{$name} }, $elem );
+ }
+ if ( ! $self->{__force_array_all} ) {
+ foreach my $key ( keys %$tree ) {
+ next if $self->{__force_array}->{$key};
+ next if ( 1 < scalar @{ $tree->{$key} } );
+ $tree->{$key} = shift @{ $tree->{$key} };
+ }
+ }
+ my $haschild = scalar keys %$tree;
+ if ( scalar @$text ) {
+ if ( scalar @$text == 1 ) {
+ # one text node (normal)
+ $text = shift @$text;
+ }
+ elsif ( ! scalar grep {ref $_} @$text ) {
+ # some text node splitted
+ $text = join( '', @$text );
+ }
+ else {
+ # some cdata node
+ my $join = join( '', map {ref $_ ? $$_ : $_} @$text );
+ $text = \$join;
+ }
+ if ( $haschild ) {
+ # some child nodes and also text node
+ $tree->{$self->{text_node_key}} = $text;
+ }
+ else {
+ # only text node without child nodes
+ $tree = $text;
+ }
+ }
+ elsif ( ! $haschild ) {
+ # no child and no text
+ $tree = "";
+ }
+ $tree;
+}
+
+sub hash_to_xml {
+ my $self = shift;
+ my $name = shift;
+ my $hash = shift;
+ my $out = [];
+ my $attr = [];
+ my $allkeys = [ keys %$hash ];
+ my $fo = $self->{__first_out} if ref $self->{__first_out};
+ my $lo = $self->{__last_out} if ref $self->{__last_out};
+ my $firstkeys = [ sort { $fo->{$a} <=> $fo->{$b} } grep { exists $fo->{$_} } @$allkeys ] if ref $fo;
+ my $lastkeys = [ sort { $lo->{$a} <=> $lo->{$b} } grep { exists $lo->{$_} } @$allkeys ] if ref $lo;
+ $allkeys = [ grep { ! exists $fo->{$_} } @$allkeys ] if ref $fo;
+ $allkeys = [ grep { ! exists $lo->{$_} } @$allkeys ] if ref $lo;
+ unless ( exists $self->{use_ixhash} && $self->{use_ixhash} ) {
+ $allkeys = [ sort @$allkeys ];
+ }
+ my $prelen = $self->{__attr_prefix_len};
+ my $pregex = $self->{__attr_prefix_rex};
+
+ foreach my $keys ( $firstkeys, $allkeys, $lastkeys ) {
+ next unless ref $keys;
+ my $elemkey = $prelen ? [ grep { $_ !~ $pregex } @$keys ] : $keys;
+ my $attrkey = $prelen ? [ grep { $_ =~ $pregex } @$keys ] : [];
+
+ foreach my $key ( @$elemkey ) {
+ my $val = $hash->{$key};
+ if ( !defined $val ) {
+ push( @$out, "<$key />" );
+ }
+ elsif ( UNIVERSAL::isa( $val, 'ARRAY' ) ) {
+ my $child = $self->array_to_xml( $key, $val );
+ push( @$out, $child );
+ }
+ elsif ( UNIVERSAL::isa( $val, 'SCALAR' ) ) {
+ my $child = $self->scalaref_to_cdata( $key, $val );
+ push( @$out, $child );
+ }
+ elsif ( ref $val ) {
+ my $child = $self->hash_to_xml( $key, $val );
+ push( @$out, $child );
+ }
+ else {
+ my $child = $self->scalar_to_xml( $key, $val );
+ push( @$out, $child );
+ }
+ }
+
+ foreach my $key ( @$attrkey ) {
+ my $name = substr( $key, $prelen );
+ my $val = &xml_escape( $hash->{$key} );
+ push( @$attr, ' ' . $name . '="' . $val . '"' );
+ }
+ }
+ my $jattr = join( '', @$attr );
+
+ if ( defined $name && scalar @$out && ! grep { ! /^{__indent} ) {
+ s/^(\s*<)/$self->{__indent}$1/mg foreach @$out;
+ }
+ unshift( @$out, "\n" );
+ }
+
+ my $text = join( '', @$out );
+ if ( defined $name ) {
+ if ( scalar @$out ) {
+ $text = "<$name$jattr>$text\n";
+ }
+ else {
+ $text = "<$name$jattr />\n";
+ }
+ }
+ $text;
+}
+
+sub array_to_xml {
+ my $self = shift;
+ my $name = shift;
+ my $array = shift;
+ my $out = [];
+ foreach my $val (@$array) {
+ if ( !defined $val ) {
+ push( @$out, "<$name />\n" );
+ }
+ elsif ( UNIVERSAL::isa( $val, 'ARRAY' ) ) {
+ my $child = $self->array_to_xml( $name, $val );
+ push( @$out, $child );
+ }
+ elsif ( UNIVERSAL::isa( $val, 'SCALAR' ) ) {
+ my $child = $self->scalaref_to_cdata( $name, $val );
+ push( @$out, $child );
+ }
+ elsif ( ref $val ) {
+ my $child = $self->hash_to_xml( $name, $val );
+ push( @$out, $child );
+ }
+ else {
+ my $child = $self->scalar_to_xml( $name, $val );
+ push( @$out, $child );
+ }
+ }
+
+ my $text = join( '', @$out );
+ $text;
+}
+
+sub scalaref_to_cdata {
+ my $self = shift;
+ my $name = shift;
+ my $ref = shift;
+ my $data = defined $$ref ? $$ref : '';
+ $data =~ s#(]])(>)#$1]]>';
+ my $text = $data;
+ $text = "<$name>$text\n" if ( $name ne $self->{text_node_key} );
+ $text;
+}
+
+sub scalar_to_xml {
+ my $self = shift;
+ my $name = shift;
+ my $scalar = shift;
+ my $copy = $scalar;
+ my $text = &xml_escape($copy);
+ $text = "<$name>$text\n" if ( $name ne $self->{text_node_key} );
+ $text;
+}
+
+sub write_raw_xml {
+ my $self = shift;
+ my $file = shift;
+ my $fh = Symbol::gensym();
+ open( $fh, ">$file" ) or return $self->die( "$! - $file" );
+ print $fh @_;
+ close($fh);
+}
+
+sub read_raw_xml {
+ my $self = shift;
+ my $file = shift;
+ my $fh = Symbol::gensym();
+ open( $fh, $file ) or return $self->die( "$! - $file" );
+ local $/ = undef;
+ my $text = <$fh>;
+ close($fh);
+ $text;
+}
+
+sub xml_decl_encoding {
+ my $textref = shift;
+ return unless defined $$textref;
+ my $args = ( $$textref =~ /^\s*<\?xml(\s+\S.*)\?>/s )[0] or return;
+ my $getcode = ( $args =~ /\s+encoding=(".*?"|'.*?')/ )[0] or return;
+ $getcode =~ s/^['"]//;
+ $getcode =~ s/['"]$//;
+ $getcode;
+}
+
+sub encode_from_to {
+ my $self = shift;
+ my $txtref = shift or return;
+ my $from = shift or return;
+ my $to = shift or return;
+
+ unless ( defined $Encode::EUCJPMS::VERSION ) {
+ $from = 'EUC-JP' if ( $from =~ /\beuc-?jp-?(win|ms)$/i );
+ $to = 'EUC-JP' if ( $to =~ /\beuc-?jp-?(win|ms)$/i );
+ }
+
+ my $setflag = $self->{utf8_flag} if exists $self->{utf8_flag};
+ if ( $] < 5.008001 && $setflag ) {
+ return $self->die( "Perl 5.8.1 is required for utf8_flag: $]" );
+ }
+
+ if ( $] >= 5.008 ) {
+ &load_encode();
+ my $check = ( $Encode::VERSION < 2.13 ) ? 0x400 : Encode::FB_XMLCREF();
+ if ( $] >= 5.008001 && utf8::is_utf8( $$txtref ) ) {
+ if ( $to =~ /^utf-?8$/i ) {
+ # skip
+ } else {
+ $$txtref = Encode::encode( $to, $$txtref, $check );
+ }
+ } else {
+ $$txtref = Encode::decode( $from, $$txtref );
+ if ( $to =~ /^utf-?8$/i && $setflag ) {
+ # skip
+ } else {
+ $$txtref = Encode::encode( $to, $$txtref, $check );
+ }
+ }
+ }
+ elsif ( ( uc($from) eq 'ISO-8859-1'
+ || uc($from) eq 'US-ASCII'
+ || uc($from) eq 'LATIN-1' ) && uc($to) eq 'UTF-8' ) {
+ &latin1_to_utf8($txtref);
+ }
+ else {
+ my $jfrom = &get_jcode_name($from);
+ my $jto = &get_jcode_name($to);
+ return $to if ( uc($jfrom) eq uc($jto) );
+ if ( $jfrom && $jto ) {
+ &load_jcode();
+ if ( defined $Jcode::VERSION ) {
+ Jcode::convert( $txtref, $jto, $jfrom );
+ }
+ else {
+ return $self->die( "Jcode.pm is required: $from to $to" );
+ }
+ }
+ else {
+ return $self->die( "Encode.pm is required: $from to $to" );
+ }
+ }
+ $to;
+}
+
+sub load_jcode {
+ return if defined $Jcode::VERSION;
+ local $@;
+ eval { require Jcode; };
+}
+
+sub load_encode {
+ return if defined $Encode::VERSION;
+ local $@;
+ eval { require Encode; };
+}
+
+sub latin1_to_utf8 {
+ my $strref = shift;
+ $$strref =~ s{
+ ([\x80-\xFF])
+ }{
+ pack( 'C2' => 0xC0|(ord($1)>>6),0x80|(ord($1)&0x3F) )
+ }exg;
+}
+
+sub get_jcode_name {
+ my $src = shift;
+ my $dst;
+ if ( $src =~ /^utf-?8$/i ) {
+ $dst = 'utf8';
+ }
+ elsif ( $src =~ /^euc.*jp(-?(win|ms))?$/i ) {
+ $dst = 'euc';
+ }
+ elsif ( $src =~ /^(shift.*jis|cp932|windows-31j)$/i ) {
+ $dst = 'sjis';
+ }
+ elsif ( $src =~ /^iso-2022-jp/ ) {
+ $dst = 'jis';
+ }
+ $dst;
+}
+
+sub xml_escape {
+ my $str = shift;
+ return '' unless defined $str;
+ # except for TAB(\x09),CR(\x0D),LF(\x0A)
+ $str =~ s{
+ ([\x00-\x08\x0B\x0C\x0E-\x1F\x7F])
+ }{
+ sprintf( '&#%d;', ord($1) );
+ }gex;
+ $str =~ s/&(?!#(\d+;|x[\dA-Fa-f]+;))/&/g;
+ $str =~ s//>/g;
+ $str =~ s/'/'/g;
+ $str =~ s/"/"/g;
+ $str;
+}
+
+sub xml_unescape {
+ my $str = shift;
+ my $map = {qw( quot " lt < gt > apos ' amp & )};
+ $str =~ s{
+ (&(?:\#(\d+)|\#x([0-9a-fA-F]+)|(quot|lt|gt|apos|amp));)
+ }{
+ $4 ? $map->{$4} : &char_deref($1,$2,$3);
+ }gex;
+ $str;
+}
+
+sub char_deref {
+ my( $str, $dec, $hex ) = @_;
+ if ( defined $dec ) {
+ return &code_to_utf8( $dec ) if ( $dec < 256 );
+ }
+ elsif ( defined $hex ) {
+ my $num = hex($hex);
+ return &code_to_utf8( $num ) if ( $num < 256 );
+ }
+ return $str;
+}
+
+sub code_to_utf8 {
+ my $code = shift;
+ if ( $code < 128 ) {
+ return pack( C => $code );
+ }
+ elsif ( $code < 256 ) {
+ return pack( C2 => 0xC0|($code>>6), 0x80|($code&0x3F));
+ }
+ elsif ( $code < 65536 ) {
+ return pack( C3 => 0xC0|($code>>12), 0x80|(($code>>6)&0x3F), 0x80|($code&0x3F));
+ }
+ return shift if scalar @_; # default value
+ sprintf( '&#x%04X;', $code );
+}
+
+1;
diff --git a/share/perl/test/OpenSimTest.pm b/share/perl/test/OpenSimTest.pm
new file mode 100644
index 0000000..a24ae22
--- /dev/null
+++ b/share/perl/test/OpenSimTest.pm
@@ -0,0 +1,53 @@
+package OpenSimTest;
+
+use strict;
+use PerformanceTest;
+use OpenSimTest::Config;
+use OpenSimTest::UserTester;
+use OpenSimTest::GridTester;
+use OpenSimTest::AssetTester;
+use OpenSimTest::InventoryTester;
+
+sub init {
+ UserTester::init();
+ GridTester::init();
+ AssetTester::init();
+ InventoryTester::init();
+}
+
+sub SingleTest {
+ my $url = shift;
+ my $methodname = shift;
+ my @ARGS = @_;
+
+ if (!$OpenSimTest::Config::HANDLER_LIST{$methodname}) {
+ Carp::croak("unknown handler name: [$methodname]");
+ } else {
+ my $handler = $OpenSimTest::Config::HANDLER_LIST{$methodname};
+ my $result = $handler->($url, @ARGS);
+ return $result;
+ }
+}
+
+sub PerformanceCompare {
+ my $server_name = shift;
+ my $count = shift;
+ my @args = @_;
+ my $test = new PerformanceTest();
+ {
+ my @params = @args;
+ unshift(@params, $OpenSimTest::Config::APACHE_SERVERS{$server_name});
+ $test->add_test("APACHE::$args[0]", \&OpenSimTest::SingleTest, \@params);
+ }
+ {
+ my @params = @args;
+ unshift(@params, $OpenSimTest::Config::OPENSIM_SERVERS{$server_name});
+ $test->add_test("OPENSIM::$args[0]", \&OpenSimTest::SingleTest, \@params);
+ }
+ $test->set_count($count);
+ $test->start();
+ print "\n\n";
+ #$test->bref_result();
+}
+
+1;
diff --git a/share/perl/test/OpenSimTest/AssetTester.pm b/share/perl/test/OpenSimTest/AssetTester.pm
new file mode 100644
index 0000000..ba05205
--- /dev/null
+++ b/share/perl/test/OpenSimTest/AssetTester.pm
@@ -0,0 +1,17 @@
+package AssetTester;
+
+use strict;
+use XML::Serializer;
+use OpenSim::Utility;
+
+sub init {
+ &OpenSimTest::Config::registerHandler("get_asset", \&_get_asset);
+}
+
+sub _get_asset {
+ my $url = shift || $OpenSimTest::Config::ASSET_SERVER_URL;
+ my $asset_id = shift;
+ my $res = &OpenSim::Utility::HttpGetRequest($url . "/assets/" . $asset_id) . "\n";
+}
+
+1;
diff --git a/share/perl/test/OpenSimTest/Config.pm b/share/perl/test/OpenSimTest/Config.pm
new file mode 100644
index 0000000..14ab3ed
--- /dev/null
+++ b/share/perl/test/OpenSimTest/Config.pm
@@ -0,0 +1,53 @@
+package OpenSimTest::Config;
+
+use strict;
+
+my $apache_server_host = "localhost";
+my $opensim_server_host = "localhost";
+
+# REGION
+our $SIM_RECV_KEY = "";
+our $SIM_SEND_KEY = "";
+# ASSET
+#our $ASSET_SERVER_URL = "http://127.0.0.1:8003/";
+our $ASSET_SERVER_URL = "http://$apache_server_host/opensim/asset.cgi";
+our $ASSET_RECV_KEY = "";
+our $ASSET_SEND_KEY = "";
+# USER
+#our $USER_SERVER_URL = "http://127.0.0.1:8001/";
+our $USER_SERVER_URL = "http://$apache_server_host/opensim/user.cgi";
+our $USER_RECV_KEY = "";
+our $USER_SEND_KEY = "";
+# GRID
+#our $GRID_SERVER_URL = "http://127.0.0.1:8001/";
+our $GRID_SERVER_URL = "http://$apache_server_host/opensim/grid.cgi";
+our $GRID_RECV_KEY = "";
+our $GRID_SEND_KEY = "";
+# INVENTORY
+#our $INVENTORY_SERVER_URL = "http://127.0.0.1:8004";
+our $INVENTORY_SERVER_URL = "http://$apache_server_host/opensim/inventory.cgi";
+# handler list
+our %HANDLER_LIST = ();
+
+our %APACHE_SERVERS = (
+ user => "http://$apache_server_host/opensim/user.cgi",
+ grid => "http://$apache_server_host/opensim/grid.cgi",
+ asset => "http://$apache_server_host/opensim/asset.cgi",
+ inventory => "http://$apache_server_host/opensim/inventory.cgi",
+);
+
+our %OPENSIM_SERVERS = (
+ user => "http://$opensim_server_host:8002",
+ grid => "http://$opensim_server_host:8001",
+ asset => "http://$opensim_server_host:8003",
+ inventory => "http://$opensim_server_host:8004",
+);
+
+sub registerHandler {
+ my ($name, $func) = @_;
+ $HANDLER_LIST{$name} = $func;
+}
+
+
+1;
+
diff --git a/share/perl/test/OpenSimTest/GridTester.pm b/share/perl/test/OpenSimTest/GridTester.pm
new file mode 100644
index 0000000..61fef6b
--- /dev/null
+++ b/share/perl/test/OpenSimTest/GridTester.pm
@@ -0,0 +1,62 @@
+package GridTester;
+
+use strict;
+use OpenSim::Utility;
+
+sub init {
+ &OpenSimTest::Config::registerHandler("simulator_login", \&_simulator_login);
+ &OpenSimTest::Config::registerHandler("simulator_data_request", \&_simulator_data_request);
+ &OpenSimTest::Config::registerHandler("simulator_after_region_moved", \&_simulator_after_region_moved);
+ &OpenSimTest::Config::registerHandler("map_block", \&_map_block);
+}
+
+sub _simulator_login {
+ my $url = shift || $OpenSimTest::Config::GRID_SERVER_URL;
+ my @param = @_;
+ my %xml_rpc_param = (
+ "authkey" => "null",
+ "UUID" => $param[0],
+ "sim_ip" => $param[1],
+ "sim_port" => $param[2],
+ "region_locx" => 1000,
+ "region_locy" => 1000,
+ "sim_name" => "OpenTest",
+ "http_port" => 9000,
+ "remoting_port" => 8895,
+ "map-image-id" => "0e5a5e87-08d9-4b37-9b8e-a4c3c4e409ab",
+ );
+ return &OpenSim::Utility::XMLRPCCall($url, "simulator_login", \%xml_rpc_param);
+}
+
+sub _map_block {
+ my $url = shift || $OpenSimTest::Config::GRID_SERVER_URL;
+ my @param = @_;
+ my %xml_rpc_param = (
+ xmin => $param[0],
+ ymin => $param[1],
+ xmax => $param[2],
+ ymax => $param[3],
+ );
+ return &OpenSim::Utility::XMLRPCCall($url, "map_block", \%xml_rpc_param);
+}
+
+sub _simulator_data_request {
+ my $url = shift || $OpenSimTest::Config::GRID_SERVER_URL;
+ my @param = @_;
+ my %xml_rpc_param = (
+ region_handle => $param[0],
+ authkey => undef,
+ );
+ return &OpenSim::Utility::XMLRPCCall($url, "simulator_data_request", \%xml_rpc_param);
+}
+
+sub _simulator_after_region_moved {
+ my $url = shift || $OpenSimTest::Config::GRID_SERVER_URL;
+ my @param = @_;
+ my %xml_rpc_param = (
+ UUID => $param[0],
+ );
+ return &OpenSim::Utility::XMLRPCCall($url, "simulator_after_region_moved", \%xml_rpc_param);
+}
+
+1;
diff --git a/share/perl/test/OpenSimTest/InventoryTester.pm b/share/perl/test/OpenSimTest/InventoryTester.pm
new file mode 100644
index 0000000..76615b1
--- /dev/null
+++ b/share/perl/test/OpenSimTest/InventoryTester.pm
@@ -0,0 +1,116 @@
+package InventoryTester;
+
+use strict;
+use XML::Serializer;
+use OpenSim::Utility;
+
+sub init {
+ &OpenSimTest::Config::registerHandler("create_inventory", \&_create_inventory);
+ &OpenSimTest::Config::registerHandler("root_folders", \&_root_folders);
+ &OpenSimTest::Config::registerHandler("get_inventory", \&_get_inventory);
+ &OpenSimTest::Config::registerHandler("new_item", \&_new_item);
+ &OpenSimTest::Config::registerHandler("new_folder", \&_new_folder);
+}
+
+sub _apache_flag {
+ my $url = shift;
+ return $url =~ /inventory.cgi/ ? 1 : 0;
+}
+
+sub _new_folder {
+ my $url = shift || $OpenSimTest::Config::INVENTORY_SERVER_URL;
+ my $post_data =<<"POSTDATA";
+
+New Folder
+
+b9cb58e8-f3c9-4af5-be47-029762baa68f
+
+
+500ea141-2967-49e2-9e18-fcdedffe68df
+
+
+aa6f9220-c945-0b23-6141-43c9ef734100
+
+-1
+0
+
+POSTDATA
+ if (&_apache_flag($url)) {
+ $post_data = "POSTDATA=" . $post_data; # TODO: bad temporary solution
+ }
+ my $res = &OpenSim::Utility::HttpPostRequest($url . "/NewFolder/", $post_data) . "\n";
+}
+
+sub _new_item {
+ my $url = shift || $OpenSimTest::Config::INVENTORY_SERVER_URL;
+ my $post_data =<<"POSTDATA";
+
+
+f975d038-3bd7-4e8b-a945-f46b0c962ee3
+
+
+5f50f162-1cc6-4907-99be-a4c81d7f5e10
+
+6
+6
+
+7018dc23-43a9-493f-b3f7-869a6bbad0f3
+
+
+b9cb58e8-f3c9-4af5-be47-029762baa68f
+
+
+b9cb58e8-f3c9-4af5-be47-029762baa68f
+
+Primitive
+
+2147483647
+526053692
+2147483647
+0
+
+POSTDATA
+ if (&_apache_flag($url)) {
+ $post_data = "POSTDATA=" . $post_data;
+ }
+ my $res = &OpenSim::Utility::HttpPostRequest($url . "/NewItem/", $post_data) . "\n";
+}
+
+sub _get_inventory {
+ my $url = shift || $OpenSimTest::Config::INVENTORY_SERVER_URL;
+ my $uuid = shift;
+ my $serializer = new XML::Serializer($uuid, "guid");
+ my $post_data = $serializer->to_string(XML::Serializer::WITH_HEADER);
+ if (&_apache_flag($url)) {
+ $post_data = "POSTDATA=" . $post_data;
+ }
+ my $res = &OpenSim::Utility::HttpPostRequest($url . "/GetInventory/", $post_data) . "\n";
+ return 1;
+}
+
+sub _create_inventory {
+ my $url = shift || $OpenSimTest::Config::INVENTORY_SERVER_URL;
+ my $uuid = shift;
+ my $serializer = new XML::Serializer($uuid, "guid");
+ my $post_data = $serializer->to_string(XML::Serializer::WITH_HEADER);
+ if (&_apache_flag($url)) {
+ $post_data = "POSTDATA=" . $post_data;
+ }
+ my $res = &OpenSim::Utility::HttpPostRequest($url . "/CreateInventory/", $post_data) . "\n";
+ return 1;
+}
+
+sub _root_folders {
+ my $url = shift || $OpenSimTest::Config::INVENTORY_SERVER_URL;
+ my $uuid = shift;
+ my $serializer = new XML::Serializer($uuid, "guid");
+ my $post_data = $serializer->to_string(XML::Serializer::WITH_HEADER);
+ if (&_apache_flag($url)) {
+ $post_data = "POSTDATA=" . $post_data;
+ }
+ my $res = &OpenSim::Utility::HttpPostRequest($url . "/RootFolders/", $post_data) . "\n";
+ return 1;
+}
+
+1;
+
diff --git a/share/perl/test/OpenSimTest/UserTester.pm b/share/perl/test/OpenSimTest/UserTester.pm
new file mode 100644
index 0000000..194102a
--- /dev/null
+++ b/share/perl/test/OpenSimTest/UserTester.pm
@@ -0,0 +1,53 @@
+package UserTester;
+
+use strict;
+use Digest::MD5;
+use OpenSim::Utility;
+
+my $user_server_url;
+
+sub init {
+ &OpenSimTest::Config::registerHandler("login_to_simulator", \&_login_to_simulator);
+ &OpenSimTest::Config::registerHandler("get_user_by_name", \&_get_user_by_name);
+ &OpenSimTest::Config::registerHandler("get_user_by_uuid", \&_get_user_by_uuid);
+ &OpenSimTest::Config::registerHandler("get_avatar_picker_avatar", \&_get_avatar_picker_avatar);
+}
+
+sub _login_to_simulator {
+ my $url = shift || $OpenSimTest::Config::USER_SERVER_URL;
+ my @param = @_;
+ my %xml_rpc_param = (
+ first => $param[0],
+ last => $param[1],
+ passwd => "\$1\$" . Digest::MD5::md5_hex($param[2]),
+ start => "last",
+ version => "1.18.3.5",
+ mac => "cc82e1e2bfd24e5424d66b4fd3f70d55",
+ );
+ return &OpenSim::Utility::XMLRPCCall($url, "login_to_simulator", \%xml_rpc_param);
+}
+
+sub _get_user_by_name {
+ my $url = shift || $OpenSimTest::Config::USER_SERVER_URL;
+ my @param = @_;
+ my %xml_rpc_param = (
+ avatar_name => $param[0],
+ );
+ return &OpenSim::Utility::XMLRPCCall($url, "get_user_by_name", \%xml_rpc_param);
+}
+
+# sample uuid:
+# db836502-de98-49c9-9edc-b90a67beb0a8
+sub _get_user_by_uuid {
+ my $url = shift || $OpenSimTest::Config::USER_SERVER_URL;
+ my @param = @_;
+ my %xml_rpc_param = (
+ avatar_uuid => $param[0],
+ );
+ return &OpenSim::Utility::XMLRPCCall($url, "get_user_by_uuid", \%xml_rpc_param);
+}
+
+sub _get_avatar_picker_avatar {
+}
+
+1;
diff --git a/share/perl/test/PerformanceTest.pl b/share/perl/test/PerformanceTest.pl
new file mode 100644
index 0000000..5f570e8
--- /dev/null
+++ b/share/perl/test/PerformanceTest.pl
@@ -0,0 +1,78 @@
+#!/usr/bin/perl
+
+# Usage:
+# ./PerformanceTest.pl
+# 2 variables should be changed:
+# Line 14: $fork_limit
+# Line 13: $benchmark_loop_count
+#
+
+use strict;
+use OpenSimTest;
+
+my $script = "./PerformanceTest.pl";
+my $fork_limit = 50; # the number of process
+my $benchmark_loop_count = 10000; # the number of requests sent by each process
+
+my @child_pid = ();
+
+for(1..$fork_limit) {
+ my $pid = fork;
+ if ($pid) {
+ &parent_do($pid);
+ } elsif ($pid == 0) {
+ &child_do;
+ exit(0);
+ } else {
+ die "could not fork";
+ }
+}
+
+foreach (@child_pid) {
+ waitpid($_, 0);
+}
+
+
+sub parent_do {
+ my $pid = shift;
+ push(@child_pid, $pid);
+}
+
+sub child_do {
+ #for(1..10000) {
+ # print "$_ ";
+ #}
+ &OpenSimTest::init();
+ # user
+ &OpenSimTest::PerformanceCompare("user", $benchmark_loop_count, "get_user_by_name", "Test User");
+ &OpenSimTest::PerformanceCompare("user", $benchmark_loop_count, "get_user_by_uuid", "db836502-de98-49c9-9edc-b90a67beb0a8");
+ # grid
+ &OpenSimTest::PerformanceCompare("grid", $benchmark_loop_count, "simulator_login", "3507f395-88e5-468c-a45f-d4fd96a1c668", "10.8.1.148", 9000);
+ &OpenSimTest::PerformanceCompare("grid", $benchmark_loop_count, "simulator_data_request", "1099511628032000");
+ &OpenSimTest::PerformanceCompare("grid", $benchmark_loop_count, "map_block", 999, 999, 1001, 1001);
+ # asset
+ &OpenSimTest::PerformanceCompare("asset", $benchmark_loop_count, "get_asset", "00000000000022223333000000000001");
+ # inventory
+ &OpenSimTest::PerformanceCompare("inventory", $benchmark_loop_count, "root_folders", "b9cb58e8-f3c9-4af5-be47-029762baa68f");
+ &OpenSimTest::PerformanceCompare("inventory", $benchmark_loop_count, "get_inventory", "b9cb58e8-f3c9-4af5-be47-029762baa68f");
+}
+
+__END__
+my $count = 10000;
+
+&OpenSimTest::init();
+# user
+#&OpenSimTest::PerformanceCompare("user", $count, "get_user_by_name", "Test User");
+#&OpenSimTest::PerformanceCompare("user", $count, "get_user_by_uuid", "db836502-de98-49c9-9edc-b90a67beb0a8");
+# grid
+#&OpenSimTest::PerformanceCompare("grid", $count, "simulator_login", "3507f395-88e5-468c-a45f-d4fd96a1c668", "10.8.1.148", 9000);
+#&OpenSimTest::PerformanceCompare("grid", $count, "simulator_data_request", "1099511628032000");
+#&OpenSimTest::PerformanceCompare("grid", $count, "map_block", 999, 999, 1001, 1001);
+# asset
+&OpenSimTest::PerformanceCompare("asset", $count, "get_asset", "00000000000022223333000000000001");
+# inventory
+#&OpenSimTest::PerformanceCompare("inventory", $count, "create_inventory", "b9cb58e8-f3c9-4af5-be47-029762baa68f");
+#&OpenSimTest::PerformanceCompare("inventory", $count, "root_folders", "b9cb58e8-f3c9-4af5-be47-029762baa68f");
+#&OpenSimTest::PerformanceCompare("inventory", $count, "get_inventory", "b9cb58e8-f3c9-4af5-be47-029762baa68f");
+#&OpenSimTest::PerformanceCompare("inventory", $count, "new_item");
+#&OpenSimTest::PerformanceCompare("inventory", $count, "new_folder");
diff --git a/share/perl/test/SingleTest.pl b/share/perl/test/SingleTest.pl
new file mode 100644
index 0000000..e6be081
--- /dev/null
+++ b/share/perl/test/SingleTest.pl
@@ -0,0 +1,21 @@
+#!/usr/bin/perl
+
+# usage:
+# ./SingleTest.pl $URL $METHOD @PARAMETERS
+# example
+# ./SingleTest.pl http://127.0.0.1/user.cgi get_user_by_name "Test User"
+# ./SingleTest.pl http://127.0.0.1/grid.cgi simulator_login 3507f395-88e5-468c-a45f-d4fd96a1c668 10.8.1.148 9000
+# ./SingleTest.pl http://127.0.0.1/grid.cgi map_block 999 999 1001 1001
+# ./SingleTest.pl http://127.0.0.1/asset.cgi get_asset 00000000000022223333000000000001
+#
+
+use strict;
+use Data::Dump;
+use OpenSimTest;
+
+&OpenSimTest::init();
+my $url = shift @ARGV;
+#my $url = "http://localhost:8002";
+my $result = &OpenSimTest::SingleTest($url, @ARGV);
+Data::Dump::dump($result);
+
diff --git a/share/perl/user.cgi b/share/perl/user.cgi
new file mode 100644
index 0000000..3fa63aa
--- /dev/null
+++ b/share/perl/user.cgi
@@ -0,0 +1,28 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Carp;
+use XML::RPC;
+use MyCGI;
+use OpenSim::Utility;
+use OpenSim::UserServer;
+
+my $param = &MyCGI::getParam();
+my $request = $param->{'POSTDATA'};
+&OpenSim::Utility::Log("user", "request", $request);
+my $xmlrpc = new XML::RPC();
+my $response = $xmlrpc->receive($request, \&XMLRPCHandler);
+&OpenSim::Utility::Log("user", "response", $response);
+&MyCGI::outputXml("utf-8", $response);
+
+sub XMLRPCHandler {
+ my ($methodname, @param) = @_;
+ my $handler_list = &OpenSim::UserServer::getHandlerList();
+ if (!$handler_list->{$methodname}) {
+ Carp::croak("?");
+ } else {
+ my $handler = $handler_list->{$methodname};
+ $handler->(@param);
+ }
+}
+
--
cgit v1.1