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