clean out smoketrace

2 files changed, 0 insertions, 1376 deletions

diff --git a/lib/Qooxdoo/JSONRPC.pm b/lib/Qooxdoo/JSONRPC.pm
deleted file mode 100644
index bc34bca..0000000
--- a/lib/Qooxdoo/JSONRPC.pm
+++ /dev/null
@@ -1,1081 +0,0 @@
-package Qooxdoo::JSONRPC;
-
-# qooxdoo - the new era of web development
-#
-# http://qooxdoo.org
-#
-# Copyright:
-#   2006-2007 Nick Glencross
-#   2008-2009 Tobi Oetiker
-#
-# License:
-#   LGPL: http://www.gnu.org/licenses/lgpl.html
-#   EPL: http://www.eclipse.org/org/documents/epl-v10.php
-#  This software, the Qooxdoo RPC Perl backend, is licensed under the same
-#  terms as Qooxdoo itself, as included in `LICENSE.Qooxdoo'
-#
-# Authors:
-#  * Nick Glencross
-#  * Tobi Oetiker
-#
-# The JSON-RPC implementation.
-# Use perldoc on this file to view documentation
-
-use strict;
-
-use JSON;
-
-#use CGI;
-#use CGI::Session;
-
-# Enabling debugging will log information in the apache logs, and in
-# some cases provide more information in error responses
-$Qooxdoo::JSONRPC::debug = 0;
-# By default methods are located in the Qooxdoo/Services directory
-$Qooxdoo::JSONRPC::service_path = 'Qooxdoo::Services';
-# By default methods have to be prefixed by 'method_'
-$Qooxdoo::JSONRPC::method_prefix = 'method_';
-
-##############################################################################
-
-# JSON-RPC error origins
-
-use constant JsonRpcError_Origin_Server      => 1;
-use constant JsonRpcError_Origin_Application => 2;
-use constant JsonRpcError_Origin_Transport   => 3;
-use constant JsonRpcError_Origin_Client      => 4;
-
-
-# JSON-RPC server-generated error codes
-
-use constant JsonRpcError_Unknown            =>  0;
-use constant JsonRpcError_IllegalService     =>  1;
-use constant JsonRpcError_ServiceNotFound    =>  2;
-use constant JsonRpcError_ClassNotFound      =>  3;
-use constant JsonRpcError_MethodNotFound     =>  4;
-use constant JsonRpcError_ParameterMismatch  =>  5;
-use constant JsonRpcError_PermissionDenied   =>  6;
-
-# Method Accessibility values
-
-use constant Accessibility_Public            => "public";
-use constant Accessibility_Domain            => "domain";
-use constant Accessibility_Session           => "session";
-use constant Accessibility_Fail              => "fail";
-
-use constant defaultAccessibility            => Accessibility_Domain;
-
-# Script transport not-in-use setting
-
-use constant ScriptTransport_NotInUse        => -1;
-
-##############################################################################
-
-# This is the main entry point for handling requests
-
-sub handle_request
-{
-    my ($cgi, $session) = @_;
-
-    my $session_id = $session->id ();
-
-    print STDERR "Session id: $session_id\n"
-	if $Qooxdoo::JSONRPC::debug;
-
-    print $session->header(-charset=>'utf-8');
-
-    # 'selfconvert' is enabled for date conversion. Ideally we also want
-    # 'convblessed', but this then disabled 'selfconvert'.
-    my $json = new JSON (selfconvert => 1);
-
-    # Create the RPC error state
-
-    my $error = new Qooxdoo::JSONRPC::error ($json);
-
-    $error->set_session($session);
-
-    my $script_transport_id = ScriptTransport_NotInUse;
-
-    #----------------------------------------------------------------------
-
-    # Deal with various types of HTTP request and extract the JSON
-    # body
-
-    my $input;
-
-    my $request_method = $cgi->request_method || '';
-
-    if ($request_method eq 'POST')
-    {
-        my $content_type = $cgi->content_type;
-
-        print STDERR "POST Content type is '$content_type'\n"
-            if $Qooxdoo::JSONRPC::debug;
-
-        if ($content_type =~ m{application/json})
-        {
-            $input = $cgi->param('POSTDATA');
-        }
-        else
-        {
-            print "JSON-RPC request expected -- unexpected data received\n";
-            exit;
-        }
-    }
-    elsif ($request_method eq 'GET' &&
-           defined $cgi->param ('_ScriptTransport_id') &&
-           $cgi->param ('_ScriptTransport_id') != ScriptTransport_NotInUse &&
-           defined $cgi->param ('_ScriptTransport_data'))
-    {
-        print STDERR "GET request\n" if $Qooxdoo::JSONRPC::debug;
-
-        # We have what looks like a valid ScriptTransport request
-        $script_transport_id = $cgi->param ('_ScriptTransport_id');
-        $error->set_script_transport_id ($script_transport_id);
-
-        $input = $cgi->param ('_ScriptTransport_data');
-    }
-    else
-    {
-        print "Your HTTP Client is not using the JSON-RPC protocol\n";
-        exit;
-    }
-
-    #----------------------------------------------------------------------
-
-    # Transform dates into JSON which the parser can handle
-    Qooxdoo::JSONRPC::Date::transform_date (\$input);
-    my $sanitized = $input;
-    # try to NOT to print passwords
-    $sanitized =~ s/(pass[a-z]+":").+?("[,}])/${1}*******${2}/g;
-    print STDERR "JSON received: $sanitized\n" if $Qooxdoo::JSONRPC::debug;
-
-    #----------------------------------------------------------------------
-
-    # Convert the JSON string to a Perl datastructure
-
-    $@ = '';
-    my $json_input;
-    eval
-    {
-        $json_input = $json->jsonToObj ($input);
-    };
-
-    if ($@)
-    {
-        print"A bad JSON-RPC request was received which could not be parsed\n";
-        exit;
-    }
-
-    unless ($json_input && 
-            exists $json_input->{service} &&
-            exists $json_input->{method} &&
-            exists $json_input->{params})
-    {
-        print "A bad JSON-RPC request was received\n";
-        exit;
-    }
-
-    $error->set_id ($json_input->{id});
-
-    #----------------------------------------------------------------------
-
-    # Perform various sanity checks on the received request
-
-    unless ($json_input->{service} =~ /^[_.a-zA-Z0-9]+$/)
-    {
-        $error->set_error (JsonRpcError_IllegalService,
-                           "Illegal character found in service name");
-        $error->send_and_exit;
-    }
-
-    if ($json_input->{service} =~ /\.\./)
-    {
-        $error->set_error (JsonRpcError_IllegalService,
-                           "Illegal use of two consecutive dots " .
-                           "in service name");
-        $error->send_and_exit;
-    }
-
-    my @service_components = split (/\./, $json_input->{service});
-
-    # Surely this can't actually happen after earlier checks?
-    foreach (@service_components)
-    {
-        unless (/^[_.a-zA-Z0-9]+$/)
-        {
-            $error->set_error (JsonRpcError_IllegalService,
-                               "A service name component does not begin " .
-                               "with a letter");
-            $error->send_and_exit;
-        }
-    }
-
-    #----------------------------------------------------------------------
-
-    # Generate the name of the module corresponding to the Service
-
-    my $module = join ('::', ($Qooxdoo::JSONRPC::service_path, @service_components));
-
-    # Attempt to load the module
-
-    $@ = '';
-    eval "require $module";
-
-    if ($@)
-    {
-        print STDERR "$@\n" if $Qooxdoo::JSONRPC::debug;
-
-        # The error description used here provides more information when
-        # debugging, but probably reveals too much on a live stable
-        # server
-
-        if ($Qooxdoo::JSONRPC::debug)
-        {
-            $error->set_error (JsonRpcError_ServiceNotFound,
-                               "Service '$module' could not be loaded ($@)");
-        }
-        else
-        {
-            $error->set_error (JsonRpcError_ServiceNotFound,
-                               "Service '$module' not found");
-        }
-        $error->send_and_exit;
-    }
-
-    #----------------------------------------------------------------------
-
-    # Determine the accessibility of the requested method
-
-    my $method = $json_input->{method};
-
-    my $accessibility = defaultAccessibility;
-
-    my $accessibility_method = "${module}::GetAccessibility";
-
-    if (defined $accessibility_method)
-    {
-        print STDERR "Module $module has GetAccessibility\n"
-            if $Qooxdoo::JSONRPC::debug;
-
-        $@ = '';
-        $accessibility = eval $accessibility_method . 
-            '($method,$accessibility,$session)';
-
-        if ($@)
-        {
-            print STDERR "$@\n" if $Qooxdoo::JSONRPC::debug;
-
-            $error->set_error (JsonRpcError_Unknown,
-                               $@);
-            $error->send_and_exit;
-        }
-
-        print STDERR "GetAccessibility for $method returns $accessibility\n"
-            if $Qooxdoo::JSONRPC::debug;
-
-    }
-
-    #----------------------------------------------------------------------
-
-    # Do referer checking based on accessibility
-
-
-    if ($accessibility eq Accessibility_Public)
-    {
-        # Nothing to do as the method is always accessible
-    }
-    elsif ($accessibility eq Accessibility_Domain)
-    {
-        my $requestUriDomain;
-
-        my $server_protocol = $cgi->server_protocol;
-
-        my $is_https = $cgi->https ? 1 : 0;
-
-        $requestUriDomain = $is_https ? 'https://' : 'http://';
-
-        $requestUriDomain .= $cgi->server_name;
-
-        $requestUriDomain .= ":" . $cgi->server_port 
-            if $cgi->server_port != ($is_https ? 443 : 80);
-
-        if ($cgi->referer and $cgi->referer !~ m|^(https?://[^/]*)|)
-        {
-            $error->set_error (JsonRpcError_PermissionDenied,
-                               "Permission denied");
-            $error->send_and_exit;
-        }
-
-        my $refererDomain = $1;
-
-        if ($refererDomain ne $requestUriDomain)
-        {
-            $error->set_error (JsonRpcError_PermissionDenied,
-                               "Permission denied");
-            $error->send_and_exit;
-        }
-
-        if (!defined $session->param ('session_referer_domain'))
-        {
-            $session->param ('session_referer_domain', $refererDomain);
-        }
-
-    }
-    elsif ($accessibility eq Accessibility_Session)
-    {
-        if ($cgi->referer !~ m|^(https?://[^/]*)|)
-        {
-            $error->set_error (JsonRpcError_PermissionDenied,
-                               "Permission denied");
-            $error->send_and_exit;
-        }
-
-        my $refererDomain = $1; 
-
-        if (defined $session->param ('session_referer_domain') &&
-            $session->param ('session_referer_domain') ne $refererDomain)
-        {
-            $error->set_error (JsonRpcError_PermissionDenied,
-                               "Permission denied");
-            $error->send_and_exit;
-        }
-        else
-        {
-            $session->param ('session_referer_domain', $refererDomain);
-        }
-    }
-    elsif ($accessibility eq Accessibility_Fail)
-    {
-        $error->set_error (JsonRpcError_PermissionDenied,
-                           "Permission denied");
-        $error->send_and_exit;
-
-    }
-    else
-    {
-        $error->set_error (JsonRpcError_PermissionDenied,
-                           "Service error: unknown accessibility");
-        $error->send_and_exit;
-    }
-
-    #----------------------------------------------------------------------
-
-    # Generate the name of the function to call and check it exists
-
-    my $package_method = ${module}.'::'.$Qooxdoo::JSONRPC::method_prefix.$method;
-
-    unless (defined &$package_method)
-    {
-        $error->set_error (JsonRpcError_MethodNotFound,
-                           "Method '$method' not found " .
-                           "in service class '$module'");
-        $error->send_and_exit;
-    }
-
-    #----------------------------------------------------------------------
-
-    # Errors from here come from the Application
-
-    $error->set_origin (JsonRpcError_Origin_Application);
-
-    # Retrieve the arguments
-
-    my $params = $json_input->{params};
-
-    unless (ref $params eq 'ARRAY')
-    {
-        $error->set_error (JsonRpcError_ParameterMismatch,
-                           "Arguments were not received in an array");
-        $error->send_and_exit;
-    }
-
-    my @params = @{$params};
-
-    # Do a shallow scan of parameters, and promote hashes which are
-    # dates
-    foreach (@params)
-    {
-        if (ref eq 'HASH' &&
-            exists $_->{Qooxdoo_date})
-        {
-            bless $_, 'Qooxdoo::JSONRPC::Date';
-        }
-    }
-
-    # Invoke the method dynamically using eval
-
-    $@ = '';
-    my @result = eval $package_method .  '($error, @params)';
-
-    if ($@)
-    {
-        print STDERR "$@\n" if $Qooxdoo::JSONRPC::debug;
-
-        $error->set_error (JsonRpcError_Unknown,
-                           $@);
-        $error->send_and_exit;
-    }
-
-    # (I've had to assume this behaviour based on the test results)
-
-    my $result;
-
-    if ($#result == 0)
-    {
-        $result = shift @result;
-    }
-    else
-    {
-        $result = \@result;
-    }
-
-    # Either send an error, or the application response
-
-    if (ref $result eq 'Qooxdoo::JSONRPC::error')
-    {
-        $error->send_and_exit ();
-    }
-
-    $result = {id     => $json_input->{id},
-               result => $result};
-
-    send_reply ($json->objToJson ($result), $script_transport_id);
-}
-
-
-##############################################################################
-
-# Send the application response
-
-sub send_reply
-{
-    my ($reply, $script_transport_id) = @_;
-
-    if ($script_transport_id == ScriptTransport_NotInUse)
-    {
-        print STDERR "Send $reply\n" if $Qooxdoo::JSONRPC::debug;
-        print $reply;
-    }
-    else
-    {
-        $reply = "qx.io.remote.ScriptTransport._requestFinished" .
-            "($script_transport_id, $reply);";
-
-        print STDERR "Send $reply\n" if $Qooxdoo::JSONRPC::debug;
-        print $reply;
-    }
-}
-
-
-##############################################################################
-
-# These two routines are useful to the Services themselves
-
-sub json_bool
-{
-    my $value = shift;
-
-    return $value ? JSON::True : JSON::False;
-}
-
-
-sub json_istrue
-{
-    my $value = shift;
-
-    my $is_true = ref $value eq 'JSON::NotString'
-        && defined $value->{value} && $value->{value} eq 'true';
-
-    return $is_true;
-}
-
-##############################################################################
-
-package Qooxdoo::JSONRPC::error;
-
-use strict;
-
-# The error object enumerates various types of error
-
-sub new
-{
-    my $self          = shift ;
-    my $class         = ref ($self) || $self ;
-
-    my $json          = shift ;
-    my $origin        = shift || Qooxdoo::JSONRPC::JsonRpcError_Origin_Server;
-    my $code          = shift || Qooxdoo::JSONRPC::JsonRpcError_Unknown;
-    my $message       = shift || "Unknown error";
-
-    $self = bless
-    {
-        json                => $json,
-        origin              => $origin,
-        code                => $code,
-        message             => $message,
-        script_transport_id => Qooxdoo::JSONRPC::ScriptTransport_NotInUse
-
-    }, $class ;
-
-    return $self ;
-}
-
-sub set_origin
-{
-    my $self   = shift;
-    my $origin = shift;
-
-    $self->{origin} = $origin;
-}
-
-sub set_error
-{
-    my $self    = shift;
-    my $code    = shift;
-    my $message = shift;
-
-    $self->{code}    = $code;
-    $self->{message} = $message;
-}
-
-sub set_id
-{
-    my $self   = shift;
-    my $id     = shift;
-
-    $self->{id} = $id;
-}
-
-sub set_session
-{
-    my $self    = shift;
-    my $session = shift;
-
-    $self->{session} = $session;
-}
-
-sub set_script_transport_id
-{
-    my $self                = shift;
-    my $script_transport_id = shift;
-
-    $self->{script_transport_id} = $script_transport_id;
-}
-
-
-sub send_and_exit
-{
-    my $self                = shift;
-
-    my $result = {'id'    => $self->{id},
-                  'error' => {origin  => $self->{origin},
-                              code    => $self->{code},
-                              message => $self->{message}}};
-
-    my $script_transport_id =  $self->{script_transport_id};
-
-    Qooxdoo::JSONRPC::send_reply ($self->{json}->objToJson ($result),
-                                  $script_transport_id);
-    exit;
-}
-
-##############################################################################
-
-# Implementation of a Date class with set/get methods
-
-package Qooxdoo::JSONRPC::Date;
-
-use strict;
-
-sub new
-{
-    my $self   = shift ;
-    my $class  = ref ($self) || $self ;
-
-    my $time   = shift;
-    $self = bless {}, $class ;
-
-    $self->set_epoch_time ($time);
-
-    return $self ;
-}
-
-
-sub set_epoch_time
-{
-    my $self = shift;
-    my $time = shift;
-
-    $time = time () unless defined $time;
-
-    my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
-        gmtime ($time);
-
-    $self->{year}        = 1900+$year;
-    $self->{month}       = $mon; # Starts from 0
-    $self->{day}         = $mday;
-    $self->{hour}        = $hour;
-    $self->{minute}      = $min;
-    $self->{second}      = $sec;
-    $self->{millisecond} = 0;
-
-    return $self;
-}
-
-
-# Month is passed in 1..12, but stored 0..11
-
-sub set
-{
-    my $self = shift;
-    my ($year, $month, $day, $hour, $minute, $second, $millisecond) = @_;
-
-    $hour        ||= 0;
-    $minute      ||= 0;
-    $second      ||= 0;
-    $millisecond ||= 0;
-
-    $self->{year}        = $year;
-    $self->{month}       = $month-1;
-    $self->{day}         = $day;
-    $self->{hour}        = $hour;
-    $self->{minute}      = $minute;
-    $self->{second}      = $second;
-    $self->{millisecond} = $millisecond;
-}
-
-sub set_year
-{
-    my $self = shift;
-    my $year = shift;
-
-    $self->{year} = $year;
-}
-
-sub set_month
-{
-    my $self  = shift;
-    my $month = shift;
-
-    $self->{month} = $month-1;
-}
-
-
-sub set_day
-{
-    my $self = shift;
-    my $day = shift;
-
-    $self->{day} = $day;
-}
-
-
-sub set_hour
-{
-    my $self = shift;
-    my $hour = shift;
-
-    $self->{hour} = $hour;
-}
-
-
-sub set_minute
-{
-    my $self   = shift;
-    my $minute = shift;
-
-    $self->{minute} = $minute;
-}
-
-sub set_second
-{
-    my $self   = shift;
-    my $second = shift;
-
-    $self->{second} = $second;
-}
-
-sub set_millisecond
-{
-    my $self        = shift;
-    my $millisecond = shift;
-
-    $self->{millisecond} = $millisecond;
-}
-
-
-
-
-sub get_year
-{
-    my $self = shift;
-
-    return $self->{year};
-}
-
-sub get_month
-{
-    my $self  = shift;
-
-    return $self->{month}+1;
-}
-
-
-sub get_day
-{
-    my $self = shift;
-
-    return $self->{day};
-}
-
-
-sub get_hour
-{
-    my $self = shift;
-
-    return $self->{hour};
-}
-
-
-sub get_minute
-{
-    my $self   = shift;
-
-    return $self->{minute};
-}
-
-sub get_second
-{
-    my $self   = shift;
-
-    return $self->{second};
-}
-
-sub get_millisecond
-{
-    my $self        = shift;
-
-    return $self->{millisecond};
-}
-
-
-# This is the special method used by the JSON module to serialise a class.
-# The feature is enabled with the 'selfconvert' parameter
-
-sub toJson
-{
-    my $self = shift;
-
-    my $time = $self->{time};
-
-    my $year        = $self->{year};
-    my $month       = $self->{month};
-    my $day         = $self->{day};
-    my $hour        = $self->{hour};
-    my $minute      = $self->{minute};
-    my $second      = $self->{second};
-    my $millisecond = $self->{millisecond};
-
-    return sprintf 'new Date(Date.UTC(%d,%d,%d,%d,%d,%d,%d))',
-    $year,
-    $month,
-    $day,
-    $hour,
-    $minute,
-    $second,
-    $millisecond;
-}
-
-# Routine to convert the date embedded in the JSON string to something
-# that can be parsed
-
-sub transform_date
-{
-    my $input_ref = shift;
-
-    ${$input_ref} =~ 
-        s/new\s+Date\s*\(Date.UTC\(
-           (\d+),(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)\)\)/
-        blessed_date($1,$2,$3,$4,$5,$6,$7)/gxe;
-}
-
-# This function is called by the regexp in transform_date
-
-sub blessed_date
-{
-    my ($year, $month, $day, $hour, $minute, $second, $millisecond) = @_;
-
-    return sprintf('{"Qooxdoo_date":1,"year":%d,"month":%d,"day":%d,"hour":%d,"minute":%d,"second":%d,"millisecond":%d}',
-                   $year,
-                   $month,
-                   $day,
-                   $hour,
-                   $minute,
-                   $second,
-                   $millisecond);
-}
-
-1;
-
-__END__
-
-##############################################################################
-
-=head1 NAME
-
-Qooxdoo::JSONRPC.pm - A Perl implementation of JSON-RPC for Qooxdoo
-
-=head1 SYNOPSIS
-
-The cgi/fcgi script
-
- #!/usr/bin/perl -w
- use strict;
- use CGI;
- use CGI::Session::Driver::file;
- # make sure session files do not clash
- $CGI::Session::Driver::file::FileName =
-    ($ENV{USER}||'').$0.'%s.session';
-
- use Qooxdoo::JSONRPC;
-
- # talk about what we do in the apache error log
- #$Qooxdoo::JSONRPC::debug = 0;
-
- # By default methods are located in Qooxdoo/Services
- #$Qooxdoo::JSONRPC::service_path = 'Qooxdoo::Services';
-
- # By default methods have to be prefixed by 'method_'
- #$Qooxdoo::JSONRPC::method_prefix = 'method_';
-
- my $cgi = new CGI;
- my $session = new CGI::Session;
- Qooxdoo::JSONRPC::handle_request ($cgi, $session);
-
- # or if you load CGI::Fast you can easily create a
- # fastcgi aware version
- #while (my $cgi = new CGI::Fast) {
- #   my $session = new CGI::Session;
- #   Qooxdoo::JSONRPC::handle_request ($cgi, $session);
- #}
-
-Along with the cgi wrapper setup a service module the example
-below shows how to handle logins on the server side.
-
- package Qooxdoo::Services::Demo;
- use strict;
-
- sub GetAccessibility {
-     # name of method about to be called
-     my $method = shift;
-     # access level based on connection
-     my $access = shift;
-     # session handle
-     my $session = shift;
-     if ($method eq 'login'
-        or $method eq 'logoff'
-        or $session->param('authenticated')||'' eq 'yes'){
-       return 'public'; # grant everyone access
-     }
-     else {
-        return 'fail'; #deny access
-     }
- }
-
- sub method_login {
-     my $error = shift;
-     my $session = $error->{session};
-     my @args = @_;
-     # if login ok
-     $session->param('authenticated','yes');
-     $session->flush();
-     return 1;
-     # if login is not ok
-     $error->set_error(101,'Login faild');
-     return $error;
- }
-
- sub method_logout {
-    my $error = shift;
-    my $session = $error->{session};
-    $session->delete();
-    $session->flush();
-    return 1;
- }
-
- sub method_fun {
-    my $error = shift;
-    my $session = $error->{session};
-    my $arg_a = shift;
-    my $arg_b = shift;
-    # do something
-    return $pointer_to_data;
- }
-
- 1;
-
-=head1 DESCRIPTION
-
-RPC-JSON is a straightforward Remote Procedure Call mechanism, primarily
-targeted at Javascript clients, and hence ideal for Qooxdoo. This module
-implements the server side handling of RPC request in perl.
-
-=head2 JSON RPC Basics
-
-JSON-RPC Services may be implemented in any language provided they provide a
-conformant implementation. This module uses the CGI module to parse
-HTTP headers, and the JSON module to manipulate the JSON body.
-
-A simple, but typical exchange might be:
-
- client->server:
-
-   {"service":"qooxdoo.test","method":"echo","id":1,"params":["Hello"],"server_data":null}
-
- server->client:
-
-   {"id":1,"result":"Client said: [Hello]"}
-
-Here the service 'qooxdoo.test' is requested to run a method called
-'echo' with an argument 'Hello'. 
-
-This Perl implementation will locate
-a module called Qooxdoo::Services::qooxdoo::test (corresponding to
-Qooxoo/Services/qooxdoo/test.pm in Perl's library path). It will
-then execute the function Qooxdoo::Services::qooxdoo::test::echo
-with the supplied arguments.
-
-The function will receive the error object as the first argument, and
-subsequent arguments as supplied by the remote call. Your method call
-would therefore start with something equivalent to:
-
-    my $error  = shift;
-    my @params = @_;
-
-See test.pm for how to deal with errors and return responses.
-
-The response is sent back with the corresponding id (essential for
-asynchronous calls).
-
-The protocol also provides an exception handling mechanism, where a
-response is formatted something like:
-
-    {"error":{"origin":2,"code":23,"message":"This is an application-provided error"},"id":21}
-
-There are 4 error origins:
-
-=over
-
-=item JsonRpcError_Origin_Server 1
-
-The error occurred within the server.
-
-=item JsonRpcError_Origin_Application 2
-
-The error occurred within the application.
-
-=item JsonRpcError_Origin_Transport 3
-
-The error occurred somewhere in the communication (not raised in this module).
-
-=item JsonRpcError_Origin_Client 4
-
-The error occurred in the client (not raised in this module).
-
-=back
-
-For Server errors, there are also some predefined error codes.
-
-=over
-
-=item JsonRpcError_Unknown 0
-
-The cause of the error was not known.
-
-=item JsonRpcError_IllegalService 1
-
-The Service name was not valid, typically due to a bad character in the name.
-
-=item JsonRpcError_ServiceNotFound 2
-
-The Service was not found. In this implementation this means that the
-module containing the Service could not be found in the library path.
-
-=item JsonRpcError_ClassNotFound 3
-
-This means the class could not be found with, is not actually raised
-by this implementation.
-
-=item JsonRpcError_MethodNotFound 4
-
-The method could not be found. This is raised if a function cannot be
-found with the method name in the requested package namespace.
-
-Note: In Perl, modules (files containing functionality) and packages
-(namespaces) are closely knitted together, but there need not be a
-one-to-one correspondence -- packages can be shared across multiple
-modules, or a module can use multiple packages. This module assumes a
-one-to-one correspondence by looking for the method in the same
-namespace as the module name.
-
-=item JsonRpcError_ParameterMismatch 5
-
-This is typically raised by individual methods when they do not
-receive the parameters they are expecting.
-
-=item JsonRpcError_PermissionDenied 6
-
-Again, this error is raised by individual methods. Remember that RPC
-calls need to be as secure as the rest of your application!
-
-=back
-
-=head2 Access Control
-
-There is also some infrastructure to implement access control. Before
-each method call, the C<GetAccessibility> method of the service is
-called. Depending on the response from C<GetAccessibility> the actual
-method will be called, or an error is returned to the remote caller.
-The example in the synopsis shows how to use that for implementing an
-authentication process.
-
-C<GetAccessibility> must return one of the following access levels
-
-=over
-
-=item Accessibility_Public ("public")
-
-The method may be called from any session, and without any checking of
-who the Referer is.
-
-=item Accessibility_Domain ("domain")
-
-The method may only be called by a script obtained via a web page
-loaded from this server.  The Referer must match the request URI,
-through the domain part.
-
-=item Accessibility_Session ("session")
-
-The Referer must match the Referer of the very first RPC request
-issued during the session.
-
-=item Accessibility_Fail ("fail")
-
-Access is denied
-
-=back
-
-=head2 Persistant Data in the Session module
-
-Methods get access to the session handle as a parameter of the error object.
-Session allows to easy storage of persistant data. Since the session module
-writes all parameters in one go, this can result in a race condition when
-two instances store data.
-
-=head1 AUTHOR
-
-Nick Glencross E<lt>nick.glencross@gmail.comE<gt>,
-Tobi Oetiker E<lt>tobi@oetiker.chE<gt>
-
-=cut
diff --git a/lib/Qooxdoo/Services/tr.pm b/lib/Qooxdoo/Services/tr.pm
deleted file mode 100644
index d78070c..0000000
--- a/lib/Qooxdoo/Services/tr.pm
+++ /dev/null
@@ -1,295 +0,0 @@
-package Qooxdoo::Services::tr;
-use strict;
-use POSIX qw(setsid);
-use Time::HiRes qw(usleep);
-use Socket;
-
-my $variant = 'butskoy';
-my $config = {
-    # Modern traceroute for Linux, version 2.0.9, Nov 19 2007
-    # Copyright (c) 2006  Dmitry Butskoy,   License: GPL
-    butskoy => [
-            {
-                arg => '-q',
-                type => 'static',
-            },
-            {
-                arg => '1',
-                type => 'static',
-            },
-            {
-                key  => 'host',
-                type => 'intern',
-            },
-            {
-                key   => 'pkglen',
-                label => 'Packetlength',
-                type => 'spinner',
-                min => 0,
-                max => 1024,
-                default => 53,
-            },
-            {
-                key     => 'method',
-                arg     => '-M',
-                label   => 'Traceroute Method',
-                type    => 'select',
-                pick    => [
-                    default => 'Classic UDP',
-                    icmp    => 'ICMP ECHO',
-                    tcp     => 'TCP Syn',
-                    udp     => 'UDP to port 53',
-                    udplite => 'UDPLITE Datagram',
-                ],
-                default => 'icmp',
-            },
-            {
-              key     => 'nofrag',
-              arg     => '-F',
-              label     => 'Do not Fragment',
-              type      => 'boolean',
-              default   => 0,
-            },
-    ],
-    # Version 1.4a12
-    lbl => [
-            {
-                arg => '-q',
-                type => 'static',
-            },
-            {
-                arg => '1',
-                type => 'static',
-            },
-            {
-                key  => 'host',
-                type => 'intern',
-            },
-            {
-                key => 'pkglen',
-                label => 'Packetlength',
-                type => 'spinner',
-                min => 0,
-                max => 1024,
-                default => 53,
-            },
-            {   
-              key     => 'icmpecho',
-              arg     => '-I',
-              label   => 'Use ICMP ECHO',
-              type    => 'boolean',
-              default => 1,
-            }
-    ]
-};
-
-sub GetAccessibility {
-     my $method = shift;
-     my $access = shift;
-     my $session = shift;
-#     if ($method eq 'auth' or $session->param('authenticated') eq 'yes'){
-        return 'public';
-#     }
-#     else {
-#         return 'fail';
-#     }
-}
-
-sub launch {
-    my $error = shift;
-    my $task = shift;
-    my $cfg = $config->{$variant};
-    my @exec;
-    for (my $i = 0;$i < @{$cfg};$i++){
-        my $ch = $cfg->[$i];
-        if ($ch->{key}){
-            if ($task->{$ch->{key}}){
-                if ($ch->{arg}){        
-                    push @exec, $ch->{arg};
-                }
-                push @exec, $task->{$ch->{key}} 
-            }
-        }
-        elsif ($ch->{arg}){
-            push @exec, $ch->{arg};
-        };
-    }
-    use Data::Dumper;
-    my $rounds = $task->{rounds};
-    my $delay = $task->{delay};
-#    warn Dumper '### task: '.$task;
-    defined(my $pid = fork) or do { $error->set_error(101,"Can't fork: $!");return $error};
-    if ($pid){
-       open my $x, ">/tmp/tr_session.$pid" or do {
-           $error->set_error(199,"Opening /tmp/tr_session.$$: $!");
-           return $error;
-       };
-       close ($x);
-       return $pid;
-    }
-    local $SIG{CHLD};
-    chdir '/'               or die "Can't chdir to /: $!";
-
-#   $|++; # unbuffer
-    open STDOUT, ">>/tmp/tr_session.$$"
-                             or die "Can't write to /tmp/tr_session.$$: $!";
-    open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
-    setsid                  or die "Can't start a new session: $!";
-    open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
-    for (my $i = 0; $i<$rounds;$i++){
-        my $start = time;
-        system "traceroute",@exec;
-        if ($? == -1) {
-            print "ERROR: failed to execute traceroute: $? $!\n";
-            exit 1;
-        }
-        elsif ($? & 127) {
-            printf "ERROR: traceroute died with signal %d, %s coredump\n",
-                 ($? & 127),  ($? & 128) ? 'with' : 'without';
-            exit 1;
-        }
-        elsif ($? != 0) {
-            printf "ERROR: traceroute exited with value %d\n", $? >> 8;
-            exit 1;
-        }
-        my $wait = $delay - (time - $start);
-        if ($wait > 0 and $i+1< $rounds){
-            print "SLEEP $wait\n";
-            sleep $wait;
-        }
-    }
-    exit 0;
-}
-
-sub get_number {
-    my $error = shift;
-    my $data = shift;
-    $data = 'Undefined' unless defined $data;
-    if ($data =~ /^(\d+)$/){
-        return $1;
-    }
-    else {
-        $error->set_error(104,"Expected a number but got: $data");
-        return $error;
-    }
-}
-
-sub method_stop_tr {
-    my $error = shift;
-    my $arg = shift; 
-    my $handle = get_number($error,$arg);
-    
-    return $handle if ref $handle;
-    my $data = "/tmp/tr_session.".$handle;
-    if (-r $data){
-        warn "Sending kill $handle";
-        if (kill('KILL',$handle)){
-            waitpid($handle,0);
-        }
-    }            
-    return 'ok';
-}
-
-
-sub method_start
-{
-    my $error = shift;
-    my $arg = shift;
-    my $session = $error->{session};
-    if ($arg->{host}){
-        my $delay = get_number($error,$arg->{delay});
-        return $delay if ref $delay;
-        my $rounds = get_number($error,$arg->{rounds});
-        return $rounds if ref $rounds;
-        return launch ($error,$arg);
-    }
-    $error->set_error(103,"No host set");
-    return $error;
-}
-
-
-sub method_poll
-{
-    my $error = shift;
-    my $arg = shift;
-    my $session = $error->{session};
-    my %return;
-    for my $pid (sort keys %$arg){
-        my $point = $arg->{$pid};
-        my $data = "/tmp/tr_session.".$pid;
-        my $problem = '';
-        if (open my $fh,$data){
-            my $again;
-            my @array;
-            my $rounds = 0;
-            waitpid($pid,1);
-            $again = kill(0, $pid);
-            my $size = -s $fh;
-            if ($point < $size and seek $fh, $point,0){
-                while (<$fh>){
-            		next if /^\s*$/ or /^traceroute to/;
-                    if (/^\s*(\d+)\s+(\S+)\s+\((\S+?)\)\s+(\S+)\s+ms/){
-                        my ($hop,$host,$ip,$value) = ($1,$2,$3,$4);
-                        $value = undef unless $value =~ /^\d+(\.\d+)?$/;
-                        push @array, [$hop,$host,$ip,$value];
-                    }
-                    elsif (/^\s*(\d+)\s+\*/){
-                        push @array, [$1,undef,undef,undef];
-                    }
-                    else {
-                        s/ERROR:\s*//;
-                        $problem .= $_;
-                    }
-                }
-                $arg->{$pid} = tell($fh);
-                $return{$pid}{data} = \@array;
-            };
-            close $fh;
-            warn 'problem: '.$problem;
-            if ($problem){
-                $return{$pid}{type} = 'error';
-                $return{$pid}{msg} = $problem;
-                delete $arg->{$pid};
-                unlink $data;
-            }
-            elsif (not $again) {
-                $return{$pid}{type} = 'state';
-                $return{$pid}{msg} = 'idle';
-                delete $arg->{$pid};
-                unlink $data;
-            }
-        }
-        else {
-            $return{$pid}{type} = 'error';
-            $return{$pid}{msg} = "Opening $data: $!";
-            delete $arg->{$pid};
-        }            
-    }
-    $return{handles} = $arg;
-    return \%return;
-}
-
-sub method_auth {
-    my $error = shift;
-    my $user = shift;
-    my $password = shift;
-    my $session = $error->{session};
-    if ($user eq 'tobi' and $password eq 'robi'){
-        $session->param('authenticated','yes');
-    }    
-}   
-
-sub method_get_config {
-    my $error = shift;
-    my @list;
-    for (my $i=0;defined $config->{$variant}[$i]; $i+=2){
-        next if not defined $config->{$variant}[$i+1]{label};
-        push @list, $config->{$variant}[$i],$config->{$variant}[$i+1];
-    };
-    return \@list;
-}
- 
-                
-
-1;
-