From 0c601b73125d1bc120e248149bf4d83ecc27f1c2 Mon Sep 17 00:00:00 2001
From: Justin Clarke Casey
Date: Tue, 8 Apr 2008 11:19:34 +0000
Subject: * Removing lulurun's perl UGAI from core svn, pending a link to an
external repository, as per mailing list discussion.
---
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 deletions(-)
delete mode 100644 share/perl/README
delete mode 100644 share/perl/asset.cgi
delete mode 100644 share/perl/conf/httpd-vhosts.conf
delete mode 100755 share/perl/conf/mod_perl-startup.pl
delete mode 100644 share/perl/grid.cgi
delete mode 100644 share/perl/inventory.cgi
delete mode 100644 share/perl/lib/DBHandler.pm
delete mode 100644 share/perl/lib/MyCGI.pm
delete mode 100644 share/perl/lib/OpenSim/AssetServer.pm
delete mode 100644 share/perl/lib/OpenSim/AssetServer/AssetManager.pm
delete mode 100644 share/perl/lib/OpenSim/AssetServer/Config.pm
delete mode 100644 share/perl/lib/OpenSim/Config.pm
delete mode 100644 share/perl/lib/OpenSim/GridServer.pm
delete mode 100644 share/perl/lib/OpenSim/GridServer/Config.pm
delete mode 100644 share/perl/lib/OpenSim/GridServer/GridManager.pm
delete mode 100644 share/perl/lib/OpenSim/InventoryServer.pm
delete mode 100644 share/perl/lib/OpenSim/InventoryServer/Config.pm
delete mode 100644 share/perl/lib/OpenSim/InventoryServer/InventoryManager.pm
delete mode 100644 share/perl/lib/OpenSim/UserServer.pm
delete mode 100644 share/perl/lib/OpenSim/UserServer/Config.pm
delete mode 100644 share/perl/lib/OpenSim/UserServer/UserManager.pm
delete mode 100644 share/perl/lib/OpenSim/Utility.pm
delete mode 100644 share/perl/lib/XML/RPC.pm
delete mode 100644 share/perl/lib/XML/Serializer.pm
delete mode 100644 share/perl/lib/XML/Simple.pm
delete mode 100644 share/perl/lib/XML/TreePP.pm
delete mode 100644 share/perl/test/OpenSimTest.pm
delete mode 100644 share/perl/test/OpenSimTest/AssetTester.pm
delete mode 100644 share/perl/test/OpenSimTest/Config.pm
delete mode 100644 share/perl/test/OpenSimTest/GridTester.pm
delete mode 100644 share/perl/test/OpenSimTest/InventoryTester.pm
delete mode 100644 share/perl/test/OpenSimTest/UserTester.pm
delete mode 100755 share/perl/test/PerformanceTest.pl
delete mode 100755 share/perl/test/SingleTest.pl
delete mode 100644 share/perl/user.cgi
(limited to 'share')
diff --git a/share/perl/README b/share/perl/README
deleted file mode 100644
index 28bd9bf..0000000
--- a/share/perl/README
+++ /dev/null
@@ -1,40 +0,0 @@
-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
deleted file mode 100644
index 318e06f..0000000
--- a/share/perl/asset.cgi
+++ /dev/null
@@ -1,43 +0,0 @@
-#!/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
deleted file mode 100644
index 447150f..0000000
--- a/share/perl/conf/httpd-vhosts.conf
+++ /dev/null
@@ -1,25 +0,0 @@
-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
deleted file mode 100755
index e8bdb2c..0000000
--- a/share/perl/conf/mod_perl-startup.pl
+++ /dev/null
@@ -1,34 +0,0 @@
-# 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
deleted file mode 100644
index cf1550f..0000000
--- a/share/perl/grid.cgi
+++ /dev/null
@@ -1,27 +0,0 @@
-#!/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
deleted file mode 100644
index 0542436..0000000
--- a/share/perl/inventory.cgi
+++ /dev/null
@@ -1,39 +0,0 @@
-#!/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
deleted file mode 100644
index 1435ba2..0000000
--- a/share/perl/lib/DBHandler.pm
+++ /dev/null
@@ -1,119 +0,0 @@
-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
deleted file mode 100644
index 1f232aa..0000000
--- a/share/perl/lib/MyCGI.pm
+++ /dev/null
@@ -1,91 +0,0 @@
-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
deleted file mode 100644
index 6418166..0000000
--- a/share/perl/lib/OpenSim/AssetServer.pm
+++ /dev/null
@@ -1,87 +0,0 @@
-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
deleted file mode 100644
index f36ab1a..0000000
--- a/share/perl/lib/OpenSim/AssetServer/AssetManager.pm
+++ /dev/null
@@ -1,34 +0,0 @@
-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
deleted file mode 100644
index 5598921..0000000
--- a/share/perl/lib/OpenSim/AssetServer/Config.pm
+++ /dev/null
@@ -1,24 +0,0 @@
-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
deleted file mode 100644
index 246ef26..0000000
--- a/share/perl/lib/OpenSim/Config.pm
+++ /dev/null
@@ -1,41 +0,0 @@
-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
deleted file mode 100644
index 7b21cd8..0000000
--- a/share/perl/lib/OpenSim/GridServer.pm
+++ /dev/null
@@ -1,208 +0,0 @@
-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
deleted file mode 100644
index dc72e5a..0000000
--- a/share/perl/lib/OpenSim/GridServer/Config.pm
+++ /dev/null
@@ -1,50 +0,0 @@
-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
deleted file mode 100644
index 2170d74..0000000
--- a/share/perl/lib/OpenSim/GridServer/GridManager.pm
+++ /dev/null
@@ -1,57 +0,0 @@
-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
deleted file mode 100644
index 184e19a..0000000
--- a/share/perl/lib/OpenSim/InventoryServer.pm
+++ /dev/null
@@ -1,249 +0,0 @@
-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
deleted file mode 100644
index 64dbdd1..0000000
--- a/share/perl/lib/OpenSim/InventoryServer/Config.pm
+++ /dev/null
@@ -1,51 +0,0 @@
-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
deleted file mode 100644
index 97111b7..0000000
--- a/share/perl/lib/OpenSim/InventoryServer/InventoryManager.pm
+++ /dev/null
@@ -1,86 +0,0 @@
-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
deleted file mode 100644
index 77117e1..0000000
--- a/share/perl/lib/OpenSim/UserServer.pm
+++ /dev/null
@@ -1,239 +0,0 @@
-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
deleted file mode 100644
index da628ed..0000000
--- a/share/perl/lib/OpenSim/UserServer/Config.pm
+++ /dev/null
@@ -1,125 +0,0 @@
-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
deleted file mode 100644
index ce35329..0000000
--- a/share/perl/lib/OpenSim/UserServer/UserManager.pm
+++ /dev/null
@@ -1,49 +0,0 @@
-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
deleted file mode 100644
index 7fc91e7..0000000
--- a/share/perl/lib/OpenSim/Utility.pm
+++ /dev/null
@@ -1,155 +0,0 @@
-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
deleted file mode 100644
index 2e08867..0000000
--- a/share/perl/lib/XML/RPC.pm
+++ /dev/null
@@ -1,217 +0,0 @@
-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
deleted file mode 100644
index 6e64f17..0000000
--- a/share/perl/lib/XML/Serializer.pm
+++ /dev/null
@@ -1,163 +0,0 @@
-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
deleted file mode 100644
index 993669b..0000000
--- a/share/perl/lib/XML/Simple.pm
+++ /dev/null
@@ -1,3284 +0,0 @@
-# $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
deleted file mode 100644
index bd03db7..0000000
--- a/share/perl/lib/XML/TreePP.pm
+++ /dev/null
@@ -1,1228 +0,0 @@
-=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
deleted file mode 100644
index a24ae22..0000000
--- a/share/perl/test/OpenSimTest.pm
+++ /dev/null
@@ -1,53 +0,0 @@
-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
deleted file mode 100644
index ba05205..0000000
--- a/share/perl/test/OpenSimTest/AssetTester.pm
+++ /dev/null
@@ -1,17 +0,0 @@
-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
deleted file mode 100644
index 14ab3ed..0000000
--- a/share/perl/test/OpenSimTest/Config.pm
+++ /dev/null
@@ -1,53 +0,0 @@
-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
deleted file mode 100644
index 61fef6b..0000000
--- a/share/perl/test/OpenSimTest/GridTester.pm
+++ /dev/null
@@ -1,62 +0,0 @@
-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
deleted file mode 100644
index 76615b1..0000000
--- a/share/perl/test/OpenSimTest/InventoryTester.pm
+++ /dev/null
@@ -1,116 +0,0 @@
-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
deleted file mode 100644
index 194102a..0000000
--- a/share/perl/test/OpenSimTest/UserTester.pm
+++ /dev/null
@@ -1,53 +0,0 @@
-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
deleted file mode 100755
index 5f570e8..0000000
--- a/share/perl/test/PerformanceTest.pl
+++ /dev/null
@@ -1,78 +0,0 @@
-#!/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
deleted file mode 100755
index e6be081..0000000
--- a/share/perl/test/SingleTest.pl
+++ /dev/null
@@ -1,21 +0,0 @@
-#!/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
deleted file mode 100644
index 3fa63aa..0000000
--- a/share/perl/user.cgi
+++ /dev/null
@@ -1,28 +0,0 @@
-#!/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