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