added initial 0.8 port ... not quite working yet

2 files changed, 1265 insertions, 0 deletions

diff --git a/lib/Qooxdoo/JSONRPC.pm b/lib/Qooxdoo/JSONRPC.pm
new file mode 100644
index 0000000..b948ffb
--- /dev/null
+++ b/lib/Qooxdoo/JSONRPC.pm
@@ -0,0 +1,970 @@
+package Qooxdoo::JSONRPC;
+
+# qooxdoo - the new era of web development
+#
+# http://qooxdoo.org
+#
+# Copyright:
+#   2006-2007 Nick Glencross
+#
+# License:
+#   LGPL: http://www.gnu.org/licenses/lgpl.html
+#   EPL: http://www.eclipse.org/org/documents/epl-v10.php
+#   See the LICENSE file in the project's top-level directory for details.
+#
+# Authors:
+#  * Nick Glencross
+
+# 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;
+
+##############################################################################
+
+# 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;
+
+    # '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', 'Services', @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}::method_${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);
+}
+
+
+
+##############################################################################
+
+=head1 NAME
+
+Qooxdoo::JSONRPC.pm - A Perl implementation of JSON-RPC for Qooxdoo
+
+=head1 SYNOPSIS
+
+RPC-JSON is a straightforward Remote Procedure Call mechanism, primarily
+targeted at Javascript clients, and hence ideal for Qooxdoo.
+
+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 are 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 4
+
+=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 4
+
+=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-for-one correspondence -- packages can be shared across multiple
+modules, or a module can use multiple packages. This module assumes a
+one-for-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
+
+There is also some infrastructure to allow access control on methods
+depending on the relationship of the referer. Have a look at test.pm
+to see how this can be done by defining C<GetAccessibility> which
+returns one of the following for a supplied method name:
+
+=over 4
+
+=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
+
+=head1 AUTHOR
+
+Nick Glencross E<lt>nick.glencross@gmail.comE<gt>
+
+=cut
+
+
+1;
diff --git a/lib/Qooxdoo/Services/tr.pm b/lib/Qooxdoo/Services/tr.pm
new file mode 100644
index 0000000..d78070c
--- /dev/null
+++ b/lib/Qooxdoo/Services/tr.pm
@@ -0,0 +1,295 @@
+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;
+