From ff7b9de82908baf1d5f9af71e35dad2369bfdc2f Mon Sep 17 00:00:00 2001 From: Tobi Oetiker Date: Wed, 14 Nov 2007 17:33:19 +0000 Subject: initial qooxdoo drop for smokeping --- qooxdoo/source/class/Smokeping/Application.js | 106 ++ qooxdoo/source/class/Smokeping/io/Rpc.js | 80 ++ qooxdoo/source/class/Smokeping/ui/TargetTree.js | 71 + qooxdoo/source/index.html | 7 + qooxdoo/source/jsonrpc.cgi | 26 + qooxdoo/source/perl/CGI/Session.pm | 1369 ++++++++++++++++++++ qooxdoo/source/perl/CGI/Session/Driver.pm | 202 +++ qooxdoo/source/perl/CGI/Session/Driver/DBI.pm | 236 ++++ qooxdoo/source/perl/CGI/Session/Driver/db_file.pm | 201 +++ qooxdoo/source/perl/CGI/Session/Driver/file.pm | 217 ++++ qooxdoo/source/perl/CGI/Session/Driver/mysql.pm | 113 ++ .../source/perl/CGI/Session/Driver/postgresql.pm | 134 ++ qooxdoo/source/perl/CGI/Session/Driver/sqlite.pm | 99 ++ qooxdoo/source/perl/CGI/Session/ErrorHandler.pm | 73 ++ qooxdoo/source/perl/CGI/Session/ID/incr.pm | 77 ++ qooxdoo/source/perl/CGI/Session/ID/md5.pm | 41 + qooxdoo/source/perl/CGI/Session/ID/static.pm | 55 + .../source/perl/CGI/Session/Serialize/default.pm | 139 ++ .../perl/CGI/Session/Serialize/freezethaw.pm | 55 + qooxdoo/source/perl/CGI/Session/Serialize/json.pm | 64 + .../source/perl/CGI/Session/Serialize/storable.pm | 60 + qooxdoo/source/perl/CGI/Session/Serialize/yaml.pm | 67 + qooxdoo/source/perl/CGI/Session/Test/Default.pm | 426 ++++++ qooxdoo/source/perl/CGI/Session/Tutorial.pm | 357 +++++ qooxdoo/source/perl/JSON.pm | 725 +++++++++++ qooxdoo/source/perl/JSON/Converter.pm | 473 +++++++ qooxdoo/source/perl/JSON/PP.pm | 1355 +++++++++++++++++++ qooxdoo/source/perl/JSON/PP5005.pm | 82 ++ qooxdoo/source/perl/JSON/PP56.pm | 184 +++ qooxdoo/source/perl/JSON/Parser.pm | 419 ++++++ qooxdoo/source/perl/Qooxdoo/JSONRPC.pm | 957 ++++++++++++++ qooxdoo/source/perl/Qooxdoo/Services/Smokeping.pm | 34 + qooxdoo/source/resource/image/ajax-loader.gif | Bin 0 -> 10819 bytes qooxdoo/source/script/Smokeping.js | 168 +++ qooxdoo/source/translation/C.po | 20 + qooxdoo/source/translation/de.po | 223 ++++ qooxdoo/source/translation/en.po | 202 +++ qooxdoo/source/translation/fr.po | 21 + qooxdoo/source/translation/it.po | 183 +++ qooxdoo/source/translation/messages.pot | 21 + 40 files changed, 9342 insertions(+) create mode 100644 qooxdoo/source/class/Smokeping/Application.js create mode 100644 qooxdoo/source/class/Smokeping/io/Rpc.js create mode 100644 qooxdoo/source/class/Smokeping/ui/TargetTree.js create mode 100644 qooxdoo/source/index.html create mode 100755 qooxdoo/source/jsonrpc.cgi create mode 100644 qooxdoo/source/perl/CGI/Session.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Driver.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Driver/DBI.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Driver/db_file.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Driver/file.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Driver/mysql.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Driver/postgresql.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Driver/sqlite.pm create mode 100644 qooxdoo/source/perl/CGI/Session/ErrorHandler.pm create mode 100644 qooxdoo/source/perl/CGI/Session/ID/incr.pm create mode 100644 qooxdoo/source/perl/CGI/Session/ID/md5.pm create mode 100644 qooxdoo/source/perl/CGI/Session/ID/static.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Serialize/default.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Serialize/freezethaw.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Serialize/json.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Serialize/storable.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Serialize/yaml.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Test/Default.pm create mode 100644 qooxdoo/source/perl/CGI/Session/Tutorial.pm create mode 100755 qooxdoo/source/perl/JSON.pm create mode 100755 qooxdoo/source/perl/JSON/Converter.pm create mode 100755 qooxdoo/source/perl/JSON/PP.pm create mode 100755 qooxdoo/source/perl/JSON/PP5005.pm create mode 100755 qooxdoo/source/perl/JSON/PP56.pm create mode 100755 qooxdoo/source/perl/JSON/Parser.pm create mode 100644 qooxdoo/source/perl/Qooxdoo/JSONRPC.pm create mode 100644 qooxdoo/source/perl/Qooxdoo/Services/Smokeping.pm create mode 100644 qooxdoo/source/resource/image/ajax-loader.gif create mode 100644 qooxdoo/source/script/Smokeping.js create mode 100644 qooxdoo/source/translation/C.po create mode 100644 qooxdoo/source/translation/de.po create mode 100644 qooxdoo/source/translation/en.po create mode 100644 qooxdoo/source/translation/fr.po create mode 100644 qooxdoo/source/translation/it.po create mode 100644 qooxdoo/source/translation/messages.pot (limited to 'qooxdoo/source') diff --git a/qooxdoo/source/class/Smokeping/Application.js b/qooxdoo/source/class/Smokeping/Application.js new file mode 100644 index 0000000..49a151d --- /dev/null +++ b/qooxdoo/source/class/Smokeping/Application.js @@ -0,0 +1,106 @@ +/* ************************************************************************ + +#module(Smokeping) +#resource(Smokeping.image:image) +#embed(Smokeping.image/*) + +************************************************************************ */ + +qx.Class.define( + 'Smokeping.Application', { + extend: qx.application.Gui, + + members: + { + main: function() + { + var self=this; + this.base(arguments); + + // this will provide access to the server side of this app + var rpc = new Smokeping.io.Rpc('http://localhost/~oetiker/smq'); + + var base_url = rpc.getBaseUrl(); + + var prime = new qx.ui.layout.VerticalBoxLayout(); + with(prime){ + setPadding(8); + setLocation(0,0); + setWidth('100%'); + setHeight('100%'); + setSpacing(10); + }; + prime.addToDocument(); + var title = new qx.ui.basic.Atom(this.tr('Smokeping Viewer')); + with(title){ + setTextColor('#b0b0b0'); + setFont(qx.ui.core.Font.fromString('16px bold sans-serif')); + } + prime.add(title); + + var splitpane = new qx.ui.splitpane.HorizontalSplitPane('1*', '3*'); + splitpane.setEdge(1); + splitpane.setHeight('1*'); + splitpane.setShowKnob(true); + prime.add(splitpane); + + var tree = new Smokeping.ui.TargetTree(rpc,this.tr("Root Node")); + splitpane.addLeft(tree); + + var graphs = new qx.ui.layout.VerticalBoxLayout(); + with(graphs){ + setBackgroundColor('white'); + setBorder('inset'); + setWidth('100%'); + setHeight('100%'); + }; + + splitpane.addRight(graphs); + + + }, + + close : function(e) + { + this.base(arguments); + // return "Smokeping Web UI: " + // + "Do you really want to close the application?"; + }, + + + terminate : function(e) { + this.base(arguments); + }, + + /******************************************************************** + * Functional Block Methods + ********************************************************************/ + + /** + * Get the base url of this page + * + * @return {String} the base url of the page + */ + + __getBaseUrl: function() { + var our_href = new String(document.location.href); + var last_slash = our_href.lastIndexOf("/"); + return our_href.substring(0,last_slash+1); + } + }, + + + + + /* + ***************************************************************************** + SETTINGS + ***************************************************************************** + */ + + settings : { + 'Smokeping.resourceUri' : './resource' + } + } +); + diff --git a/qooxdoo/source/class/Smokeping/io/Rpc.js b/qooxdoo/source/class/Smokeping/io/Rpc.js new file mode 100644 index 0000000..327d2c4 --- /dev/null +++ b/qooxdoo/source/class/Smokeping/io/Rpc.js @@ -0,0 +1,80 @@ +/* ************************************************************************ +#module(Smokeping) +************************************************************************ */ + +/** + * A smokeping specific rpc call which works + */ + +qx.Class.define('Smokeping.io.Rpc', +{ + extend: qx.io.remote.Rpc, + + /* + ***************************************************************************** + CONSTRUCTOR + ***************************************************************************** + */ + + /** + * @param local_url {String} When running the application in file:// mode. + * where will we find our RPC server. + */ + construct: function (local_url) { + + with(this){ + base(arguments); + setTimeout(7000000); + setUrl('jsonrpc.cgi'); + setServiceName('Smokeping'); + } + + var our_href = new String(document.location.href); + var last_slash = our_href.lastIndexOf("/"); + this.__base_url = our_href.substring(0,last_slash+1); + + // look for services on the localhost if we access the + // application locally + + if ( document.location.host === '' ) { + with(this){ + __base_url = local_url; + setUrl(__base_url + 'jsonrpc.cgi'); + setCrossDomain(true); + } + } + + return this; + }, + + /* + ***************************************************************************** + MEMBERS + ***************************************************************************** + */ + + members : + { + + /* + --------------------------------------------------------------------------- + CORE METHODS + --------------------------------------------------------------------------- + */ + + /** + * Tell about the BaseUrl we found. + * + * @type member + * + * @param {void} + * + * @return BaseUrl {Strings} + */ + + getBaseUrl: function(){ + return this.__base_url; + } + } +}); + diff --git a/qooxdoo/source/class/Smokeping/ui/TargetTree.js b/qooxdoo/source/class/Smokeping/ui/TargetTree.js new file mode 100644 index 0000000..6c47398 --- /dev/null +++ b/qooxdoo/source/class/Smokeping/ui/TargetTree.js @@ -0,0 +1,71 @@ +/* ************************************************************************ +#module(Smokeping) +************************************************************************ */ + +/** + * a widget showing the smokeping target tree + */ + +qx.Class.define('Smokeping.ui.TargetTree', +{ + extend: qx.ui.tree.Tree, + + /* + ***************************************************************************** + CONSTRUCTOR + ***************************************************************************** + */ + + /** + * @param root_node {String} Name of the root node + * where will we find our RPC server. + * + * @param rpc {rpcObject} An rpc object providing access to the Smokeping service + */ + + construct: function (rpc,root_node) { + + with(this){ + base(arguments,root_node); + setBackgroundColor('white'); + setBorder('inset'); + setWidth('100%'); + setHeight('100%'); + setPadding(5); + } + + return this; + }, + + /* + ***************************************************************************** + MEMBERS + ***************************************************************************** + */ + + members : + { + + /* + --------------------------------------------------------------------------- + CORE METHODS + --------------------------------------------------------------------------- + */ + + /** + * Tell about the BaseUrl we found. + * + * @type member + * + * @param {void} + * + * @return BaseUrl {Strings} + */ + +// getBaseUrl: function(){ +// return this.__base_url; +// } + } +}); + + diff --git a/qooxdoo/source/index.html b/qooxdoo/source/index.html new file mode 100644 index 0000000..4dd0962 --- /dev/null +++ b/qooxdoo/source/index.html @@ -0,0 +1,7 @@ + + + + Smokeping + + + diff --git a/qooxdoo/source/jsonrpc.cgi b/qooxdoo/source/jsonrpc.cgi new file mode 100755 index 0000000..372273d --- /dev/null +++ b/qooxdoo/source/jsonrpc.cgi @@ -0,0 +1,26 @@ +#!/usr/sepp/bin/perl-5.8.8 -w +use strict; +use lib qw( perl ); + +use CGI; +use CGI::Session; +use Qooxdoo::JSONRPC; + +$Qooxdoo::JSONRPC::debug=1; + +# Change this space-separated list of directories to include +# Qooxdoo::JSONRPC.pm and co-located Services + +# If this module can't be found, the previous line is incorrect + +# Instantiating the CGI module which parses the HTTP request + +my $cgi = new CGI; +my $session = new CGI::Session; + +# You can customise this harness here to handle cases before treating +# the request as being JSON-RPC + +Qooxdoo::JSONRPC::handle_request ($cgi, $session); + + diff --git a/qooxdoo/source/perl/CGI/Session.pm b/qooxdoo/source/perl/CGI/Session.pm new file mode 100644 index 0000000..a5e59ac --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session.pm @@ -0,0 +1,1369 @@ +package CGI::Session; + +# $Id: Session.pm 353 2006-12-05 02:10:19Z markstos $ + +use strict; +use Carp; +use CGI::Session::ErrorHandler; + +@CGI::Session::ISA = qw( CGI::Session::ErrorHandler ); +$CGI::Session::VERSION = '4.20'; +$CGI::Session::NAME = 'CGISESSID'; +$CGI::Session::IP_MATCH = 0; + +sub STATUS_NEW () { 1 } # denotes session that's just created +sub STATUS_MODIFIED () { 2 } # denotes session that needs synchronization +sub STATUS_DELETED () { 4 } # denotes session that needs deletion +sub STATUS_EXPIRED () { 8 } # denotes session that was expired. + +sub import { + my ($class, @args) = @_; + + return unless @args; + + ARG: + foreach my $arg (@args) { + if ($arg eq '-ip_match') { + $CGI::Session::IP_MATCH = 1; + last ARG; + } + } +} + +sub new { + my ($class, @args) = @_; + + my $self; + if (ref $class) { + # + # Called as an object method as in $session->new()... + # + $self = bless { %$class }, ref( $class ); + $class = ref $class; + $self->_reset_status(); + # + # Object may still have public data associated with it, but we + # don't care about that, since we want to leave that to the + # client's disposal. However, if new() was requested on an + # expired session, we already know that '_DATA' table is + # empty, since it was the job of flush() to empty '_DATA' + # after deleting. How do we know flush() was already called on + # an expired session? Because load() - constructor always + # calls flush() on all to-be expired sessions + # + } + else { + # + # Called as a class method as in CGI::Session->new() + # + $self = $class->load( @args ); + if (not defined $self) { + return $class->set_error( "new(): failed: " . $class->errstr ); + } + } + my $dataref = $self->{_DATA}; + unless ($dataref->{_SESSION_ID}) { + # + # Absence of '_SESSION_ID' can only signal: + # * Expired session: Because load() - constructor is required to + # empty contents of _DATA - table + # * Unavailable session: Such sessions are the ones that don't + # exist on datastore, but are requested by client + # * New session: When no specific session is requested to be loaded + # + my $id = $self->_id_generator()->generate_id( + $self->{_DRIVER_ARGS}, + $self->{_CLAIMED_ID} + ); + unless (defined $id) { + return $self->set_error( "Couldn't generate new SESSION-ID" ); + } + $dataref->{_SESSION_ID} = $id; + $dataref->{_SESSION_CTIME} = $dataref->{_SESSION_ATIME} = time(); + $self->_set_status( STATUS_NEW ); + } + return $self; +} + +sub DESTROY { $_[0]->flush() } +sub close { $_[0]->flush() } + +*param_hashref = \&dataref; +my $avoid_single_use_warning = *param_hashref; +sub dataref { $_[0]->{_DATA} } + +sub is_empty { !defined($_[0]->id) } + +sub is_expired { $_[0]->_test_status( STATUS_EXPIRED ) } + +sub is_new { $_[0]->_test_status( STATUS_NEW ) } + +sub id { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_ID} : undef } + +# Last Access Time +sub atime { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_ATIME} : undef } + +# Creation Time +sub ctime { return defined($_[0]->dataref) ? $_[0]->dataref->{_SESSION_CTIME} : undef } + +sub _driver { + my $self = shift; + defined($self->{_OBJECTS}->{driver}) and return $self->{_OBJECTS}->{driver}; + my $pm = "CGI::Session::Driver::" . $self->{_DSN}->{driver}; + defined($self->{_OBJECTS}->{driver} = $pm->new( $self->{_DRIVER_ARGS} )) + or die $pm->errstr(); + return $self->{_OBJECTS}->{driver}; +} + +sub _serializer { + my $self = shift; + defined($self->{_OBJECTS}->{serializer}) and return $self->{_OBJECTS}->{serializer}; + return $self->{_OBJECTS}->{serializer} = "CGI::Session::Serialize::" . $self->{_DSN}->{serializer}; +} + + +sub _id_generator { + my $self = shift; + defined($self->{_OBJECTS}->{id}) and return $self->{_OBJECTS}->{id}; + return $self->{_OBJECTS}->{id} = "CGI::Session::ID::" . $self->{_DSN}->{id}; +} + +sub _ip_matches { + return ( $_[0]->{_DATA}->{_SESSION_REMOTE_ADDR} eq $ENV{REMOTE_ADDR} ); +} + + +# parses the DSN string and returns it as a hash. +# Notably: Allows unique abbreviations of the keys: driver, serializer and 'id'. +# Also, keys and values of the returned hash are lower-cased. +sub parse_dsn { + my $self = shift; + my $dsn_str = shift; + croak "parse_dsn(): usage error" unless $dsn_str; + + require Text::Abbrev; + my $abbrev = Text::Abbrev::abbrev( "driver", "serializer", "id" ); + my %dsn_map = map { split /:/ } (split /;/, $dsn_str); + my %dsn = map { $abbrev->{lc $_}, lc $dsn_map{$_} } keys %dsn_map; + return \%dsn; +} + +sub query { + my $self = shift; + + if ( $self->{_QUERY} ) { + return $self->{_QUERY}; + } +# require CGI::Session::Query; +# return $self->{_QUERY} = CGI::Session::Query->new(); + require CGI; + return $self->{_QUERY} = CGI->new(); +} + + +sub name { + my $self = shift; + + if (ref $self) { + unless ( @_ ) { + return $self->{_NAME} || $CGI::Session::NAME; + } + return $self->{_NAME} = $_[0]; + } + + $CGI::Session::NAME = $_[0] if @_; + return $CGI::Session::NAME; +} + + +sub dump { + my $self = shift; + + require Data::Dumper; + my $d = Data::Dumper->new([$self], [ref $self]); + $d->Deepcopy(1); + return $d->Dump(); +} + + +sub _set_status { + my $self = shift; + croak "_set_status(): usage error" unless @_; + $self->{_STATUS} |= $_ for @_; +} + + +sub _unset_status { + my $self = shift; + croak "_unset_status(): usage error" unless @_; + $self->{_STATUS} &= ~$_ for @_; +} + + +sub _reset_status { + $_[0]->{_STATUS} = 0; +} + +sub _test_status { + return $_[0]->{_STATUS} & $_[1]; +} + + +sub flush { + my $self = shift; + + # Would it be better to die or err if something very basic is wrong here? + # I'm trying to address the DESTORY related warning + # from: http://rt.cpan.org/Ticket/Display.html?id=17541 + # return unless defined $self; + + return unless $self->id; # <-- empty session + return if !defined($self->{_STATUS}) or $self->{_STATUS} == 0; # <-- neither new, nor deleted nor modified + + if ( $self->_test_status(STATUS_NEW) && $self->_test_status(STATUS_DELETED) ) { + $self->{_DATA} = {}; + return $self->_unset_status(STATUS_NEW, STATUS_DELETED); + } + + my $driver = $self->_driver(); + my $serializer = $self->_serializer(); + + if ( $self->_test_status(STATUS_DELETED) ) { + defined($driver->remove($self->id)) or + return $self->set_error( "flush(): couldn't remove session data: " . $driver->errstr ); + $self->{_DATA} = {}; # <-- removing all the data, making sure + # it won't be accessible after flush() + return $self->_unset_status(STATUS_DELETED); + } + + if ( $self->_test_status(STATUS_NEW) || $self->_test_status(STATUS_MODIFIED) ) { + my $datastr = $serializer->freeze( $self->dataref ); + unless ( defined $datastr ) { + return $self->set_error( "flush(): couldn't freeze data: " . $serializer->errstr ); + } + defined( $driver->store($self->id, $datastr) ) or + return $self->set_error( "flush(): couldn't store datastr: " . $driver->errstr); + $self->_unset_status(STATUS_NEW, STATUS_MODIFIED); + } + return 1; +} + +sub trace {} +sub tracemsg {} + +sub param { + my ($self, @args) = @_; + + if ($self->_test_status( STATUS_DELETED )) { + carp "param(): attempt to read/write deleted session"; + } + + # USAGE: $s->param(); + # DESC: Returns all the /public/ parameters + if (@args == 0) { + return grep { !/^_SESSION_/ } keys %{ $self->{_DATA} }; + } + # USAGE: $s->param( $p ); + # DESC: returns a specific session parameter + elsif (@args == 1) { + return $self->{_DATA}->{ $args[0] } + } + + + # USAGE: $s->param( -name => $n, -value => $v ); + # DESC: Updates session data using CGI.pm's 'named param' syntax. + # Only public records can be set! + my %args = @args; + my ($name, $value) = @args{ qw(-name -value) }; + if (defined $name && defined $value) { + if ($name =~ m/^_SESSION_/) { + + carp "param(): attempt to write to private parameter"; + return undef; + } + $self->_set_status( STATUS_MODIFIED ); + return $self->{_DATA}->{ $name } = $value; + } + + # USAGE: $s->param(-name=>$n); + # DESC: access to session data (public & private) using CGI.pm's 'named parameter' syntax. + return $self->{_DATA}->{ $args{'-name'} } if defined $args{'-name'}; + + # USAGE: $s->param($name, $value); + # USAGE: $s->param($name1 => $value1, $name2 => $value2 [,...]); + # DESC: updates one or more **public** records using simple syntax + if ((@args % 2) == 0) { + my $modified_cnt = 0; + ARG_PAIR: + while (my ($name, $val) = each %args) { + if ( $name =~ m/^_SESSION_/) { + carp "param(): attempt to write to private parameter"; + next ARG_PAIR; + } + $self->{_DATA}->{ $name } = $val; + ++$modified_cnt; + } + $self->_set_status(STATUS_MODIFIED); + return $modified_cnt; + } + + # If we reached this far none of the expected syntax were + # detected. Syntax error + croak "param(): usage error. Invalid syntax"; +} + + + +sub delete { $_[0]->_set_status( STATUS_DELETED ) } + + +*header = \&http_header; +my $avoid_single_use_warning_again = *header; +sub http_header { + my $self = shift; + return $self->query->header(-cookie=>$self->cookie, -type=>'text/html', @_); +} + +sub cookie { + my $self = shift; + + my $query = $self->query(); + my $cookie= undef; + + if ( $self->is_expired ) { + $cookie = $query->cookie( -name=>$self->name, -value=>$self->id, -expires=> '-1d', @_ ); + } + elsif ( my $t = $self->expire ) { + $cookie = $query->cookie( -name=>$self->name, -value=>$self->id, -expires=> '+' . $t . 's', @_ ); + } + else { + $cookie = $query->cookie( -name=>$self->name, -value=>$self->id, @_ ); + } + return $cookie; +} + + + + + +sub save_param { + my $self = shift; + my ($query, $params) = @_; + + $query ||= $self->query(); + $params ||= [ $query->param ]; + + for my $p ( @$params ) { + my @values = $query->param($p) or next; + if ( @values > 1 ) { + $self->param($p, \@values); + } else { + $self->param($p, $values[0]); + } + } + $self->_set_status( STATUS_MODIFIED ); +} + + + +sub load_param { + my $self = shift; + my ($query, $params) = @_; + + $query ||= $self->query(); + $params ||= [ $self->param ]; + + for ( @$params ) { + $query->param(-name=>$_, -value=>$self->param($_)); + } +} + + +sub clear { + my $self = shift; + my $params = shift; + #warn ref($params); + if (defined $params) { + $params = [ $params ] unless ref $params; + } + else { + $params = [ $self->param ]; + } + + for ( grep { ! /^_SESSION_/ } @$params ) { + delete $self->{_DATA}->{$_}; + } + $self->_set_status( STATUS_MODIFIED ); +} + + +sub find { + my $class = shift; + my ($dsn, $coderef, $dsn_args); + + # find( \%code ) + if ( @_ == 1 ) { + $coderef = $_[0]; + } + # find( $dsn, \&code, \%dsn_args ) + else { + ($dsn, $coderef, $dsn_args) = @_; + } + + unless ( $coderef && ref($coderef) && (ref $coderef eq 'CODE') ) { + croak "find(): usage error."; + } + + my $driver; + if ( $dsn ) { + my $hashref = $class->parse_dsn( $dsn ); + $driver = $hashref->{driver}; + } + $driver ||= "file"; + my $pm = "CGI::Session::Driver::" . ($driver =~ /(.*)/)[0]; + eval "require $pm"; + if (my $errmsg = $@ ) { + return $class->set_error( "find(): couldn't load driver." . $errmsg ); + } + + my $driver_obj = $pm->new( $dsn_args ); + unless ( $driver_obj ) { + return $class->set_error( "find(): couldn't create driver object. " . $pm->errstr ); + } + + my $dont_update_atime = 0; + my $driver_coderef = sub { + my ($sid) = @_; + my $session = $class->load( $dsn, $sid, $dsn_args, $dont_update_atime ); + unless ( $session ) { + return $class->set_error( "find(): couldn't load session '$sid'. " . $class->errstr ); + } + $coderef->( $session ); + }; + + defined($driver_obj->traverse( $driver_coderef )) + or return $class->set_error( "find(): traverse seems to have failed. " . $driver_obj->errstr ); + return 1; +} + +# $Id: Session.pm 353 2006-12-05 02:10:19Z markstos $ + +=pod + +=head1 NAME + +CGI::Session - persistent session data in CGI applications + +=head1 SYNOPSIS + + # Object initialization: + use CGI::Session; + $session = new CGI::Session(); + + $CGISESSID = $session->id(); + + # send proper HTTP header with cookies: + print $session->header(); + + # storing data in the session + $session->param('f_name', 'Sherzod'); + # or + $session->param(-name=>'l_name', -value=>'Ruzmetov'); + + # flush the data from memory to the storage driver at least before your + # program finishes since auto-flushing can be unreliable + $session->flush(); + + # retrieving data + my $f_name = $session->param('f_name'); + # or + my $l_name = $session->param(-name=>'l_name'); + + # clearing a certain session parameter + $session->clear(["l_name", "f_name"]); + + # expire '_is_logged_in' flag after 10 idle minutes: + $session->expire('is_logged_in', '+10m') + + # expire the session itself after 1 idle hour + $session->expire('+1h'); + + # delete the session for good + $session->delete(); + +=head1 DESCRIPTION + +CGI-Session is a Perl5 library that provides an easy, reliable and modular session management system across HTTP requests. +Persistency is a key feature for such applications as shopping carts, login/authentication routines, and application that +need to carry data across HTTP requests. CGI::Session does that and many more. + +=head1 TRANSLATIONS + +This document is also available in Japanese. + +=over 4 + +=item o + +Translation based on 4.14: http://digit.que.ne.jp/work/index.cgi?Perldoc/ja + +=item o + +Translation based on 3.11, including Cookbook and Tutorial: http://perldoc.jp/docs/modules/CGI-Session-3.11/ + +=back + +=head1 TO LEARN MORE + +Current manual is optimized to be used as a quick reference. To learn more both about the philosophy and CGI::Session +programming style, consider the following: + +=over 4 + +=item * + +L - extended CGI::Session manual. Also includes library architecture and driver specifications. + +=item * + +We also provide mailing lists for CGI::Session users. To subscribe to the list or browse the archives visit https://lists.sourceforge.net/lists/listinfo/cgi-session-user + +=item * + +B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt + +=item * + +L - standard CGI library + +=item * + +L - another fine alternative to CGI::Session. + +=back + +=head1 METHODS + +Following is the overview of all the available methods accessible via CGI::Session object. + +=head2 new() + +=head2 new( $sid ) + +=head2 new( $query ) + +=head2 new( $dsn, $query||$sid ) + +=head2 new( $dsn, $query||$sid, \%dsn_args ) + +Constructor. Returns new session object, or undef on failure. Error message is accessible through L. If called on an already initialized session will re-initialize the session based on already configured object. This is only useful after a call to L. + +Can accept up to three arguments, $dsn - Data Source Name, $query||$sid - query object OR a string representing session id, and finally, \%dsn_args, arguments used by $dsn components. + +If called without any arguments, $dsn defaults to I, $query||$sid defaults to C<< CGI->new() >>, and C<\%dsn_args> defaults to I. + +If called with a single argument, it will be treated either as C<$query> object, or C<$sid>, depending on its type. If argument is a string , C will treat it as session id and will attempt to retrieve the session from data store. If it fails, will create a new session id, which will be accessible through L. If argument is an object, L and L methods will be called on that object to recover a potential C<$sid> and retrieve it from data store. If it fails, C will create a new session id, which will be accessible through L. C will define the name of the query parameter and/or cookie name to be requested, defaults to I. + +If called with two arguments first will be treated as $dsn, and second will be treated as $query or $sid or undef, depending on its type. Some examples of this syntax are: + + $s = CGI::Session->new("driver:mysql", undef); + $s = CGI::Session->new("driver:sqlite", $sid); + $s = CGI::Session->new("driver:db_file", $query); + $s = CGI::Session->new("serializer:storable;id:incr", $sid); + # etc... + + +Following data source components are supported: + +=over 4 + +=item * + +B - CGI::Session driver. Available drivers are L, L, L and L. Third party drivers are welcome. For driver specs consider L + +=item * + +B - serializer to be used to encode the data structure before saving +in the disk. Available serializers are L, L and L. Default serializer will use L. + +=item * + +B - ID generator to use when new session is to be created. Available ID generator is L + +=back + +For example, to get CGI::Session store its data using DB_File and serialize data using FreezeThaw: + + $s = new CGI::Session("driver:DB_File;serializer:FreezeThaw", undef); + +If called with three arguments, first two will be treated as in the previous example, and third argument will be C<\%dsn_args>, which will be passed to C<$dsn> components (namely, driver, serializer and id generators) for initialization purposes. Since all the $dsn components must initialize to some default value, this third argument should not be required for most drivers to operate properly. + +undef is acceptable as a valid placeholder to any of the above arguments, which will force default behavior. + +=head2 load() + +=head2 load($query||$sid) + +=head2 load($dsn, $query||$sid) + +=head2 load($dsn, $query, \%dsn_args); + +Accepts the same arguments as new(), and also returns a new session object, or +undef on failure. The difference is, L can create new session if +it detects expired and non-existing sessions, but C does not. + +C is useful to detect expired or non-existing sessions without forcing the library to create new sessions. So now you can do something like this: + + $s = CGI::Session->load() or die CGI::Session->errstr(); + if ( $s->is_expired ) { + print $s->header(), + $cgi->start_html(), + $cgi->p("Your session timed out! Refresh the screen to start new session!") + $cgi->end_html(); + exit(0); + } + + if ( $s->is_empty ) { + $s = $s->new() or die $s->errstr; + } + +Notice, all I sessions are empty, but not all I sessions are expired! + +=cut + +# pass a true value as the fourth parameter if you want to skip the changing of +# access time This isn't documented more formally, because it only called by +# find(). +sub load { + my $class = shift; + return $class->set_error( "called as instance method") if ref $class; + return $class->set_error( "Too many arguments") if @_ > 4; + + my $self = bless { + _DATA => { + _SESSION_ID => undef, + _SESSION_CTIME => undef, + _SESSION_ATIME => undef, + _SESSION_REMOTE_ADDR => $ENV{REMOTE_ADDR} || "", + # + # Following two attributes may not exist in every single session, and declaring + # them now will force these to get serialized into database, wasting space. But they + # are here to remind the coder of their purpose + # +# _SESSION_ETIME => undef, +# _SESSION_EXPIRE_LIST => {} + }, # session data + _DSN => {}, # parsed DSN params + _OBJECTS => {}, # keeps necessary objects + _DRIVER_ARGS=> {}, # arguments to be passed to driver + _CLAIMED_ID => undef, # id **claimed** by client + _STATUS => 0, # status of the session object + _QUERY => undef # query object + }, $class; + + my ($dsn,$query_or_sid,$dsn_args,$update_atime); + # load($query||$sid) + if ( @_ == 1 ) { + $self->_set_query_or_sid($_[0]); + } + # Two or more args passed: + # load($dsn, $query||$sid) + elsif ( @_ > 1 ) { + ($dsn, $query_or_sid, $dsn_args,$update_atime) = @_; + + # Since $update_atime is not part of the public API + # we ignore any value but the one we use internally: 0. + if (defined $update_atime and $update_atime ne '0') { + return $class->set_error( "Too many arguments"); + } + + if ( defined $dsn ) { # <-- to avoid 'Uninitialized value...' warnings + $self->{_DSN} = $self->parse_dsn($dsn); + } + $self->_set_query_or_sid($query_or_sid); + + # load($dsn, $query, \%dsn_args); + + $self->{_DRIVER_ARGS} = $dsn_args if defined $dsn_args; + + } + + $self->_load_pluggables(); + + if (not defined $self->{_CLAIMED_ID}) { + my $query = $self->query(); + eval { + $self->{_CLAIMED_ID} = $query->cookie( $self->name ) || $query->param( $self->name ); + }; + if ( my $errmsg = $@ ) { + return $class->set_error( "query object $query does not support cookie() and param() methods: " . $errmsg ); + } + } + + # No session is being requested. Just return an empty session + return $self unless $self->{_CLAIMED_ID}; + + # Attempting to load the session + my $driver = $self->_driver(); + my $raw_data = $driver->retrieve( $self->{_CLAIMED_ID} ); + unless ( defined $raw_data ) { + return $self->set_error( "load(): couldn't retrieve data: " . $driver->errstr ); + } + + # Requested session couldn't be retrieved + return $self unless $raw_data; + + my $serializer = $self->_serializer(); + $self->{_DATA} = $serializer->thaw($raw_data); + unless ( defined $self->{_DATA} ) { + #die $raw_data . "\n"; + return $self->set_error( "load(): couldn't thaw() data using $serializer:" . + $serializer->errstr ); + } + unless (defined($self->{_DATA}) && ref ($self->{_DATA}) && (ref $self->{_DATA} eq 'HASH') && + defined($self->{_DATA}->{_SESSION_ID}) ) { + return $self->set_error( "Invalid data structure returned from thaw()" ); + } + + # checking if previous session ip matches current ip + if($CGI::Session::IP_MATCH) { + unless($self->_ip_matches) { + $self->_set_status( STATUS_DELETED ); + $self->flush; + return $self; + } + } + + # checking for expiration ticker + if ( $self->{_DATA}->{_SESSION_ETIME} ) { + if ( ($self->{_DATA}->{_SESSION_ATIME} + $self->{_DATA}->{_SESSION_ETIME}) <= time() ) { + $self->_set_status( STATUS_EXPIRED ); # <-- so client can detect expired sessions + $self->_set_status( STATUS_DELETED ); # <-- session should be removed from database + $self->flush(); # <-- flush() will do the actual removal! + return $self; + } + } + + # checking expiration tickers of individuals parameters, if any: + my @expired_params = (); + while (my ($param, $max_exp_interval) = each %{ $self->{_DATA}->{_SESSION_EXPIRE_LIST} } ) { + if ( ($self->{_DATA}->{_SESSION_ATIME} + $max_exp_interval) <= time() ) { + push @expired_params, $param; + } + } + $self->clear(\@expired_params) if @expired_params; + + # We update the atime by default, but if this (otherwise undocoumented) + # parameter is explicitly set to false, we'll turn the behavior off + if ( ! defined $update_atime ) { + $self->{_DATA}->{_SESSION_ATIME} = time(); # <-- updating access time + $self->_set_status( STATUS_MODIFIED ); # <-- access time modified above + } + + return $self; +} + + +# set the input as a query object or session ID, depending on what it looks like. +sub _set_query_or_sid { + my $self = shift; + my $query_or_sid = shift; + if ( ref $query_or_sid){ $self->{_QUERY} = $query_or_sid } + else { $self->{_CLAIMED_ID} = $query_or_sid } +} + + +sub _load_pluggables { + my ($self) = @_; + + my %DEFAULT_FOR = ( + driver => "file", + serializer => "default", + id => "md5", + ); + my %SUBDIR_FOR = ( + driver => "Driver", + serializer => "Serialize", + id => "ID", + ); + my $dsn = $self->{_DSN}; + foreach my $plug qw(driver serializer id) { + my $mod_name = $dsn->{ $plug }; + if (not defined $mod_name) { + $mod_name = $DEFAULT_FOR{ $plug }; + } + if ($mod_name =~ /^(\w+)$/) { + + # Looks good. Put it into the dsn hash + $dsn->{ $plug } = $mod_name = $1; + + # Put together the actual module name to load + my $prefix = join '::', (__PACKAGE__, $SUBDIR_FOR{ $plug }, q{}); + $mod_name = $prefix . $mod_name; + + ## See if we can load load it + eval "require $mod_name"; + if ($@) { + my $msg = $@; + return $self->set_error("couldn't load $mod_name: " . $msg); + } + } + else { + # do something here about bad name for a pluggable + } + } + return; +} + +=pod + +=head2 id() + +Returns effective ID for a session. Since effective ID and claimed ID can differ, valid session id should always +be retrieved using this method. + +=head2 param($name) + +=head2 param(-name=E$name) + +Used in either of the above syntax returns a session parameter set to $name or undef if it doesn't exist. If it's called on a deleted method param() will issue a warning but return value is not defined. + +=head2 param($name, $value) + +=head2 param(-name=E$name, -value=E$value) + +Used in either of the above syntax assigns a new value to $name parameter, +which can later be retrieved with previously introduced param() syntax. C<$value> +may be a scalar, arrayref or hashref. + +Attempts to set parameter names that start with I<_SESSION_> will trigger +a warning and undef will be returned. + +=head2 param_hashref() + +B. Use L instead. + +=head2 dataref() + +Returns reference to session's data table: + + $params = $s->dataref(); + $sid = $params->{_SESSION_ID}; + $name= $params->{name}; + # etc... + +Useful for having all session data in a hashref, but too risky to update. + +=head2 save_param() + +=head2 save_param($query) + +=head2 save_param($query, \@list) + +Saves query parameters to session object. In other words, it's the same as calling L for every single query parameter returned by C<< $query->param() >>. The first argument, if present, should be either CGI object or any object which can provide param() method. If it's undef, defaults to the return value of L, which returns C<< CGI->new >>. If second argument is present and is a reference to an array, only those query parameters found in the array will be stored in the session. undef is a valid placeholder for any argument to force default behavior. + +=head2 load_param() + +=head2 load_param($query) + +=head2 load_param($query, \@list) + +Loads session parameters into a query object. The first argument, if present, should be query object, or any other object which can provide param() method. If second argument is present and is a reference to an array, only parameters found in that array will be loaded to the query object. + +=head2 clear() + +=head2 clear('field') + +=head2 clear(\@list) + +Clears parameters from the session object. + +With no parameters, all fields are cleared. If passed a single parameter or a +reference to an array, only the named parameters are cleared. + +=head2 flush() + +Synchronizes data in memory with the copy serialized by the driver. Call flush() +if you need to access the session from outside the current session object. You should +at least call flush() before your program exits. + +As a last resort, CGI::Session will automatically call flush for you just +before the program terminates or session object goes out of scope. This automatic +behavior was the recommended behavior until the 4.x series. Automatic flushing +has since proven to be unreliable, and in some cases is now required in places +that worked with 3.x. For further details see: + + http://rt.cpan.org/Ticket/Display.html?id=17541 + http://rt.cpan.org/Ticket/Display.html?id=17299 + +=head2 atime() + +Read-only method. Returns the last access time of the session in seconds from epoch. This time is used internally while +auto-expiring sessions and/or session parameters. + +=head2 ctime() + +Read-only method. Returns the time when the session was first created in seconds from epoch. + +=head2 expire() + +=head2 expire($time) + +=head2 expire($param, $time) + +Sets expiration interval relative to L. + +If used with no arguments, returns the expiration interval if it was ever set. If no expiration was ever set, returns undef. For backwards compatibility, a method named C does the same thing. + +Second form sets an expiration time. This value is checked when previously stored session is asked to be retrieved, and if its expiration interval has passed, it will be expunged from the disk immediately. Passing 0 cancels expiration. + +By using the third syntax you can set the expiration interval for a particular +session parameter, say I<~logged-in>. This would cause the library call clear() +on the parameter when its time is up. Note it only makes sense to set this value to +something I than when the whole session expires. Passing 0 cancels expiration. + +All the time values should be given in the form of seconds. Following keywords are also supported for your convenience: + + +-----------+---------------+ + | alias | meaning | + +-----------+---------------+ + | s | Second | + | m | Minute | + | h | Hour | + | d | Day | + | w | Week | + | M | Month | + | y | Year | + +-----------+---------------+ + +Examples: + + $session->expire("2h"); # expires in two hours + $session->expire(0); # cancel expiration + $session->expire("~logged-in", "10m"); # expires '~logged-in' parameter after 10 idle minutes + +Note: all the expiration times are relative to session's last access time, not to its creation time. To expire a session immediately, call L. To expire a specific session parameter immediately, call L. + +=cut + +*expires = \&expire; +my $prevent_warning = \&expires; +sub etime { $_[0]->expire() } +sub expire { + my $self = shift; + + # no params, just return the expiration time. + if (not @_) { + return $self->{_DATA}->{_SESSION_ETIME}; + } + # We have just a time + elsif ( @_ == 1 ) { + my $time = $_[0]; + # If 0 is passed, cancel expiration + if ( defined $time && ($time =~ m/^\d$/) && ($time == 0) ) { + $self->{_DATA}->{_SESSION_ETIME} = undef; + $self->_set_status( STATUS_MODIFIED ); + } + # set the expiration to this time + else { + $self->{_DATA}->{_SESSION_ETIME} = $self->_str2seconds( $time ); + $self->_set_status( STATUS_MODIFIED ); + } + } + # If we get this far, we expect expire($param,$time) + # ( This would be a great use of a Perl6 multi sub! ) + else { + my ($param, $time) = @_; + if ( ($time =~ m/^\d$/) && ($time == 0) ) { + delete $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{ $param }; + $self->_set_status( STATUS_MODIFIED ); + } else { + $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{ $param } = $self->_str2seconds( $time ); + $self->_set_status( STATUS_MODIFIED ); + } + } + return 1; +} + +# =head2 _str2seconds() +# +# my $secs = $self->_str2seconds('1d') +# +# Takes a CGI.pm-style time representation and returns an equivalent number +# of seconds. +# +# See the docs of expire() for more detail. +# +# =cut + +sub _str2seconds { + my $self = shift; + my ($str) = @_; + + return unless defined $str; + return $str if $str =~ m/^[-+]?\d+$/; + + my %_map = ( + s => 1, + m => 60, + h => 3600, + d => 86400, + w => 604800, + M => 2592000, + y => 31536000 + ); + + my ($koef, $d) = $str =~ m/^([+-]?\d+)([smhdwMy])$/; + unless ( defined($koef) && defined($d) ) { + die "_str2seconds(): couldn't parse '$str' into \$koef and \$d parts. Possible invalid syntax"; + } + return $koef * $_map{ $d }; +} + + +=pod + +=head2 is_new() + +Returns true only for a brand new session. + +=head2 is_expired() + +Tests whether session initialized using L is to be expired. This method works only on sessions initialized with load(): + + $s = CGI::Session->load() or die CGI::Session->errstr; + if ( $s->is_expired ) { + die "Your session expired. Please refresh"; + } + if ( $s->is_empty ) { + $s = $s->new() or die $s->errstr; + } + + +=head2 is_empty() + +Returns true for sessions that are empty. It's preferred way of testing whether requested session was loaded successfully or not: + + $s = CGI::Session->load($sid); + if ( $s->is_empty ) { + $s = $s->new(); + } + +Actually, the above code is nothing but waste. The same effect could've been achieved by saying: + + $s = CGI::Session->new( $sid ); + +L is useful only if you wanted to catch requests for expired sessions, and create new session afterwards. See L for an example. + +=head2 delete() + +Deletes a session from the data store and empties session data from memory, completely, so subsequent read/write requests on the same object will fail. Technically speaking, it will only set object's status to I and will trigger L, and flush() will do the actual removal. + +=head2 find( \&code ) + +=head2 find( $dsn, \&code ) + +=head2 find( $dsn, \&code, \%dsn_args ) + +Experimental feature. Executes \&code for every session object stored in disk, passing initialized CGI::Session object as the first argument of \&code. Useful for housekeeping purposes, such as for removing expired sessions. Following line, for instance, will remove sessions already expired, but are still in disk: + +The following line, for instance, will remove sessions already expired, but which are still on disk: + + CGI::Session->find( sub {} ); + +Notice, above \&code didn't have to do anything, because load(), which is called to initialize sessions inside find(), will automatically remove expired sessions. Following example will remove all the objects that are 10+ days old: + + CGI::Session->find( \&purge ); + sub purge { + my ($session) = @_; + next if $session->is_empty; # <-- already expired?! + if ( ($session->ctime + 3600*240) <= time() ) { + $session->delete() or warn "couldn't remove " . $session->id . ": " . $session->errstr; + } + } + +B: find will not change the modification or access times on the sessions it returns. + +Explanation of the 3 parameters to C: + +=over 4 + +=item $dsn + +This is the DSN (Data Source Name) used by CGI::Session to control what type of +sessions you previously created and what type of sessions you now wish method +C to pass to your callback. + +The default value is defined above, in the docs for method C, and is +'driver:file;serializer:default;id:md5'. + +Do not confuse this DSN with the DSN arguments mentioned just below, under \%dsn_args. + +=item \&code + +This is the callback provided by you (i.e. the caller of method C) +which is called by CGI::Session once for each session found by method C +which matches the given $dsn. + +There is no default value for this coderef. + +When your callback is actually called, the only parameter is a session. If you +want to call a subroutine you already have with more parameters, you can +achieve this by creating an anonymous subroutine that calls your subroutine +with the parameters you want. For example: + + CGI::Session->find($dsn, sub { my_subroutine( @_, 'param 1', 'param 2' ) } ); + CGI::Session->find($dsn, sub { $coderef->( @_, $extra_arg ) } ); + +Or if you wish, you can define a sub generator as such: + + sub coderef_with_args { + my ( $coderef, @params ) = @_; + return sub { $coderef->( @_, @params ) }; + } + + CGI::Session->find($dsn, coderef_with_args( $coderef, 'param 1', 'param 2' ) ); + +=item \%dsn_args + +If your $dsn uses file-based storage, then this hashref might contain keys such as: + + { + Directory => Value 1, + NoFlock => Value 2, + UMask => Value 3 + } + +If your $dsn uses db-based storage, then this hashref contains (up to) 3 keys, and looks like: + + { + DataSource => Value 1, + User => Value 2, + Password => Value 3 + } + +These 3 form the DSN, username and password used by DBI to control access to your database server, +and hence are only relevant when using db-based sessions. + +The default value of this hashref is undef. + +=back + +B find() is meant to be convenient, not necessarily efficient. It's best suited in cron scripts. + +=head1 MISCELLANEOUS METHODS + +=head2 remote_addr() + +Returns the remote address of the user who created the session for the first time. Returns undef if variable REMOTE_ADDR wasn't present in the environment when the session was created. + +=cut + +sub remote_addr { return $_[0]->{_DATA}->{_SESSION_REMOTE_ADDR} } + +=pod + +=head2 errstr() + +Class method. Returns last error message from the library. + +=head2 dump() + +Returns a dump of the session object. Useful for debugging purposes only. + +=head2 header() + +Replacement for L's header() method. Without this method, you usually need to create a CGI::Cookie object and send it as part of the HTTP header: + + $cookie = CGI::Cookie->new(-name=>$session->name, -value=>$session->id); + print $cgi->header(-cookie=>$cookie); + +You can minimize the above into: + + print $session->header(); + +It will retrieve the name of the session cookie from C<$session->name()> which defaults to C<$CGI::Session::NAME>. If you want to use a different name for your session cookie, do something like following before creating session object: + + CGI::Session->name("MY_SID"); + $session = new CGI::Session(undef, $cgi, \%attrs); + +Now, $session->header() uses "MY_SID" as a name for the session cookie. + +=head2 query() + +Returns query object associated with current session object. Default query object class is L. + +=head2 DEPRECATED METHODS + +These methods exist solely for for compatibility with CGI::Session 3.x. + +=head3 close() + +Closes the session. Using flush() is recommended instead, since that's exactly what a call +to close() does now. + +=head1 DISTRIBUTION + +CGI::Session consists of several components such as L, L and L. This section lists what is available. + +=head2 DRIVERS + +Following drivers are included in the standard distribution: + +=over 4 + +=item * + +L - default driver for storing session data in plain files. Full name: B + +=item * + +L - for storing session data in BerkelyDB. Requires: L. +Full name: B + +=item * + +L - for storing session data in MySQL tables. Requires L and L. +Full name: B + +=item * + +L - for storing session data in SQLite. Requires L and L. +Full name: B + +=back + +=head2 SERIALIZERS + +=over 4 + +=item * + +L - default data serializer. Uses standard L. +Full name: B. + +=item * + +L - serializes data using L. Requires L. +Full name: B. + +=item * + +L - serializes data using L. Requires L. +Full name: B + +=item * + +L - serializes data using YAML. Requires L or L. +Full name: B + +=item * + +L - serializes data using JSON. Requires L. +Full name: B + +=back + +=head2 ID GENERATORS + +Following ID generators are available: + +=over 4 + +=item * + +L - generates 32 character long hexadecimal string. Requires L. +Full name: B. + +=item * + +L - generates incremental session ids. + +=item * + +L - generates static session ids. B + +=back + + +=head1 CREDITS + +CGI::Session evolved to what it is today with the help of following developers. The list doesn't follow any strict order, but somewhat chronological. Specifics can be found in F file + +=over 4 + +=item Andy Lester + +=item Brian King Emrbbking@mac.comE + +=item Olivier Dragon Edragon@shadnet.shad.caE + +=item Adam Jacob Eadam@sysadminsith.orgE + +=item Igor Plisco Eigor@plisco.ruE + +=item Mark Stosberg + +=item Matt LeBlanc Emleblanc@cpan.orgE + +=item Shawn Sorichetti + +=back + +=head1 COPYRIGHT + +Copyright (C) 2001-2005 Sherzod Ruzmetov Esherzodr@cpan.orgE. All rights reserved. +This library is free software. You can modify and or distribute it under the same terms as Perl itself. + +=head1 PUBLIC CODE REPOSITORY + +You can see what the developers have been up to since the last release by +checking out the code repository. You can browse the Subversion repository from here: + + http://svn.cromedome.net/ + +Or check it directly with C from here: + + svn://svn.cromedome.net/CGI-Session + +=head1 SUPPORT + +If you need help using CGI::Session consider the mailing list. You can ask the list by sending your questions to +cgi-session-user@lists.sourceforge.net . + +You can subscribe to the mailing list at https://lists.sourceforge.net/lists/listinfo/cgi-session-user . + +Bug reports can be submitted at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Session + +=head1 AUTHOR + +Sherzod Ruzmetov Esherzodr@cpan.orgE, http://author.handalak.com/ + +Mark Stosberg became a co-maintainer during the development of 4.0. C. + +=head1 SEE ALSO + +=over 4 + +=item * + +L - extended CGI::Session manual + +=item * + +B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt + +=item * + +L - standard CGI library + +=item * + +L - another fine alternative to CGI::Session + +=back + +=cut + +1; + diff --git a/qooxdoo/source/perl/CGI/Session/Driver.pm b/qooxdoo/source/perl/CGI/Session/Driver.pm new file mode 100644 index 0000000..4f4b892 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Driver.pm @@ -0,0 +1,202 @@ +package CGI::Session::Driver; + +# $Id: Driver.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; +#use diagnostics; + +use Carp; +use CGI::Session::ErrorHandler; + +$CGI::Session::Driver::VERSION = "4.20"; +@CGI::Session::Driver::ISA = qw(CGI::Session::ErrorHandler); + +sub new { + my $class = shift; + my $args = shift || {}; + + unless ( ref $args ) { + croak "$class->new(): Invalid argument type passed to driver"; + } + + # perform a shallow copy of $args, to prevent modification + my $self = bless ({%$args}, $class); + return $self if $self->init(); + return $self->set_error( "%s->init() returned false", $class); +} + +sub init { 1 } + +sub retrieve { + croak "retrieve(): " . ref($_[0]) . " failed to implement this method!"; +} + +sub store { + croak "store(): " . ref($_[0]) . " failed to implement this method!"; +} + +sub remove { + croak "remove(): " . ref($_[0]) . " failed to implement this method!"; +} + +sub traverse { + croak "traverse(): " . ref($_[0]) . " failed to implement this method!"; +} + +sub dump { + require Data::Dumper; + my $d = Data::Dumper->new([$_[0]], [ref $_[0]]); + return $d->Dump; +} + + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::Driver - CGI::Session driver specifications + +=head1 WARNING + +Version 4.0 of CGI::Session's driver specification is B backward compatible with previous specification. If you already have a driver developed to work with the previous version you're highly encouraged to upgrade your driver code to make it compatible with the current version. Fortunately, current driver specs are a lot easier to adapt to. + +If you need any help converting your driver to meet current specs, send me an e-mail. For support information see +L + +=head1 SYNOPSIS + + require CGI::Session::Driver; + @ISA = qw( CGI::Session::Driver ); + +=head1 DESCRIPTION + +CGI::Session::Driver is a base class for all CGI::Session's native drivers. It also documents driver specifications for those willing to write drivers for different databases not currently supported by CGI::Session. + +=head1 WHAT IS A DRIVER + +Driver is a piece of code that helps CGI::Session library to talk to specific database engines, or storage mechanisms. To be more precise, driver is a F<.pm> file that inherits from CGI::Session::Driver and defines L, L and L methods. + +=head2 BLUEPRINT + +The best way of learning the specs is to look at a blueprint of a driver: + + package CGI::Session::Driver::your_driver_name; + use strict; + use base qw( CGI::Session::Driver CGI::Session::ErrorHandler ); + + sub init { + my ($self) = @_; + # optional + } + + sub DESTROY { + my ($self) = @_; + # optional + } + + sub store { + my ($self, $sid, $datastr) = @_; + # Store $datastr, which is an already serialized string of data. + } + + sub retrieve { + my ($self, $sid) = @_; + # Return $datastr, which was previously stored using above store() method. + # Return $datastr if $sid was found. Return 0 or "" if $sid doesn't exist + } + + sub remove { + my ($self, $sid) = @_; + # Remove storage associated with $sid. Return any true value indicating success, + # or undef on failure. + } + + sub traverse { + my ($self, $coderef) = @_; + # execute $coderef for each session id passing session id as the first and the only + # argument + } + + 1; + +All the attributes passed as the second argument to CGI::Session's new() or load() methods will automatically +be made driver's object attributes. For example, if session object was initialized as following: + + $s = CGI::Session->new("driver:your_driver_name", undef, {Directory=>'/tmp/sessions'}); + +You can access value of 'Directory' from within your driver like so: + + sub store { + my ($self, $sid, $datastr) = @_; + my $dir = $self->{Directory}; # <-- in this example will be '/tmp/sessions' + } + +Optionally, you can define C method within your driver to do driver specific global initialization. C method will be invoked only once during the lifecycle of your driver, which is the same as the lifecycle of a session object. + +For examples of C look into the source code of native CGI::Session drivers. + +=head1 METHODS + +This section lists and describes all driver methods. All the driver methods will receive driver object ($self) as the first argument. Methods that pertain to an individual session (such as C, C and C) will also receive session id ($sid) as the second argument. + +Following list describes every driver method, including its argument list and what step of session's life they will be invoked. Understanding this may help driver authors. + +=over 4 + +=item retrieve($self, $sid) + +Called whenever a specific session is requested either via C<< CGI::Session->new() >> or C<< CGI::Session->load() >> syntax. Method should try to retrieve data associated with C< $sid > and return it. In case no data could be retrieved for C< $sid > 0 (zero) or "" should be returned. undef must be returned only to signal error. Error message should be set via set_error(), which can be inherited from L. + +Tip: set_error() always returns undef. Use it for your advantage. + +=item store($self, $sid, $datastr) + +Called whenever modified session data is to be stored back to disk. This happens whenever CGI::Session->flush() is called on modified session. Since CGI::Session->DESTROY() calls flush(), store() gets requested each time session object is to be terminated. + +C< store() > is called both to store new sessions and to update already stored sessions. It's driver author's job to figure out which operation needs to be performed. + +$datastr, which is passed as the third argument to represents B session data that needs to be saved. + +store() can return any true value indicating success or undef on failure. Error message should be passed to set_error() + +=item remove($self, $sid) + +Called whenever session data is to be deleted, which is when CGI::Session->delete() is called. Should return any true value indicating success, undef on failure. Error message should be logged in set_error(). + +=item traverse($self, \&coderef) + +Called only from within CGI::Session->find(). Job of traverse() is to call \&coderef for every single session stored in disk passing session's id as the first and only argument: C<< $coderef->( $sid ) >> + +=item init($self) + +Optional. Called whenever driver object is to be initialized, which happens only once during the lifecycle of CGI::Session object. Here you can do driver-wide initialization, such as to open connection to a database server. + +=item DESTROY($self) + +Optional. Perl automatically calls this method on objects just before they are to be terminated. This gives your driver chance to close any database connections or close any open file handles. + +=back + +=head2 NOTES + +=over 4 + +=item * + +All driver F<.pm> files must be lowercase! + +=item * + +DBI-related drivers are better off using L as base, but don't have to. + +=back + +=head1 LICENSING + +For support and licensing see L. + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/Driver/DBI.pm b/qooxdoo/source/perl/CGI/Session/Driver/DBI.pm new file mode 100644 index 0000000..413be99 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Driver/DBI.pm @@ -0,0 +1,236 @@ +package CGI::Session::Driver::DBI; + +# $Id: DBI.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; + +use DBI; +use Carp; +use CGI::Session::Driver; + +@CGI::Session::Driver::DBI::ISA = ( "CGI::Session::Driver" ); +$CGI::Session::Driver::DBI::VERSION = "4.20"; + + +sub init { + my $self = shift; + if ( defined $self->{Handle} ) { + if (ref $self->{Handle} eq 'CODE') { + $self->{Handle} = $self->{Handle}->(); + } + else { + # We assume the handle is working, and there is nothing to do. + } + } + else { + $self->{Handle} = DBI->connect( + $self->{DataSource}, $self->{User}, $self->{Password}, + { RaiseError=>1, PrintError=>1, AutoCommit=>1 } + ); + unless ( $self->{Handle} ) { + return $self->set_error( "init(): couldn't connect to database: " . DBI->errstr ); + } + $self->{_disconnect} = 1; + } + return 1; +} + +# A setter/accessor method for the table name, defaulting to 'sessions' + +sub table_name { + my $self = shift; + my $class = ref( $self ) || $self; + + if ( (@_ == 0) && ref($self) && ($self->{TableName}) ) { + return $self->{TableName}; + } + + no strict 'refs'; + if ( @_ ) { + my $new_name = shift; + $self->{TableName} = $new_name; + ${ $class . "::TABLE_NAME" } = $new_name; + } + + unless (defined $self->{TableName}) { + $self->{TableName} = "sessions"; + } + + return $self->{TableName}; +} + + +sub retrieve { + my $self = shift; + my ($sid) = @_; + croak "retrieve(): usage error" unless $sid; + + + my $dbh = $self->{Handle}; + my $sth = $dbh->prepare_cached("SELECT a_session FROM " . $self->table_name . " WHERE id=?", undef, 3); + unless ( $sth ) { + return $self->set_error( "retrieve(): DBI->prepare failed with error message " . $dbh->errstr ); + } + $sth->execute( $sid ) or return $self->set_error( "retrieve(): \$sth->execute failed with error message " . $sth->errstr); + + my ($row) = $sth->fetchrow_array(); + return 0 unless $row; + return $row; +} + + +sub store { +# die; + my $self = shift; + my ($sid, $datastr) = @_; + croak "store(): usage error" unless $sid && $datastr; + + + my $dbh = $self->{Handle}; + my $sth = $dbh->prepare_cached("SELECT id FROM " . $self->table_name . " WHERE id=?", undef, 3); + unless ( defined $sth ) { + return $self->set_error( "store(): \$dbh->prepare failed with message " . $sth->errstr ); + } + + $sth->execute( $sid ) or return $self->set_error( "store(): \$sth->execute failed with message " . $sth->errstr ); + my $action_sth; + if ( $sth->fetchrow_array ) { + $action_sth = $dbh->prepare_cached("UPDATE " . $self->table_name . " SET a_session=? WHERE id=?", undef, 3); + } else { + $action_sth = $dbh->prepare_cached("INSERT INTO " . $self->table_name . " (a_session, id) VALUES(?, ?)", undef, 3); + } + + unless ( defined $action_sth ) { + return $self->set_error( "store(): \$dbh->prepare failed with message " . $dbh->errstr ); + } + $action_sth->execute($datastr, $sid) + or return $self->set_error( "store(): \$action_sth->execute failed " . $action_sth->errstr ); + return 1; +} + + +sub remove { + my $self = shift; + my ($sid) = @_; + croak "remove(): usage error" unless $sid; + + my $rc = $self->{Handle}->do( 'DELETE FROM '. $self->table_name .' WHERE id= ?',{},$sid ); + unless ( $rc ) { + croak "remove(): \$dbh->do failed!"; + } + + return 1; +} + + +sub DESTROY { + my $self = shift; + + unless ( $self->{Handle}->{AutoCommit} ) { + $self->{Handle}->commit; + } + if ( $self->{_disconnect} ) { + $self->{Handle}->disconnect; + } +} + + +sub traverse { + my $self = shift; + my ($coderef) = @_; + + unless ( $coderef && ref( $coderef ) && (ref $coderef eq 'CODE') ) { + croak "traverse(): usage error"; + } + + my $tablename = $self->table_name(); + my $sth = $self->{Handle}->prepare_cached("SELECT id FROM $tablename", undef, 3) + or return $self->set_error("traverse(): couldn't prepare SQL statement. " . $self->{Handle}->errstr); + $sth->execute() or return $self->set_error("traverse(): couldn't execute statement $sth->{Statement}. " . $sth->errstr); + + while ( my ($sid) = $sth->fetchrow_array ) { + $coderef->($sid); + } + return 1; +} + + +1; + +=pod + +=head1 NAME + +CGI::Session::Driver::DBI - Base class for native DBI-related CGI::Session drivers + +=head1 SYNOPSIS + + require CGI::Session::Driver::DBI; + @ISA = qw( CGI::Session::Driver::DBI ); + +=head1 DESCRIPTION + +In most cases you can create a new DBI-driven CGI::Session driver by simply creating an empty driver file that inherits from CGI::Session::Driver::DBI. That's exactly what L does. The only reason why this class doesn't suit for a valid driver is its name isn't in lowercase. I'm serious! + +=head2 NOTES + +CGI::Session::Driver::DBI defines init() method, which makes DBI handle available for drivers in I - object attribute regardless of what C<\%dsn_args> were used in creating session object. Should your driver require non-standard initialization you have to re-define init() method in your F<.pm> file, but make sure to set 'Handle' - object attribute to database handle (returned by DBI->connect(...)) if you wish to inherit any of the methods from CGI::Session::Driver::DBI. + +=head1 STORAGE + +Before you can use any DBI-based session drivers you need to make sure compatible database table is created for CGI::Session to work with. Following command will produce minimal requirements in most SQL databases: + + CREATE TABLE sessions ( + id CHAR(32) NOT NULL PRIMARY KEY, + a_session TEXT NOT NULL + ); + +Your session table can define additional columns, but the above two are required. Name of the session table is expected to be I by default. You may use a different name if you wish. To do this you have to pass I as part of your C< \%dsn_args >: + + $s = new CGI::Session("driver:sqlite", undef, {TableName=>'my_sessions'}); + $s = new CGI::Session("driver:mysql", undef, { + TableName=>'my_sessions', + DataSource=>'dbi:mysql:shopping_cart'}); + +=head1 DRIVER ARGUMENTS + +Following driver arguments are supported: + +=over 4 + +=item DataSource + +First argument to be passed to L->L. If the driver makes +the database connection itself, it will also explicitly disconnect from the database when +the driver object is DESTROYed. + +=item User + +User privileged to connect to the database defined in C. + +=item Password + +Password of the I privileged to connect to the database defined in C + +=item Handle + +An existing L database handle object. The handle can be created on demand +by providing a code reference as a argument, such as C<connect}>>. +This way, the database connection is only created if it actually needed. This can be useful +when combined with a framework plugin like L, which creates +a CGI::Session object on demand as well. + +C will override all the above arguments, if any present. + +=item TableName + +Name of the table session data will be stored in. + +=back + +=head1 LICENSING + +For support and licensing information see L + +=cut + diff --git a/qooxdoo/source/perl/CGI/Session/Driver/db_file.pm b/qooxdoo/source/perl/CGI/Session/Driver/db_file.pm new file mode 100644 index 0000000..edfe8d6 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Driver/db_file.pm @@ -0,0 +1,201 @@ +package CGI::Session::Driver::db_file; + +# $Id: db_file.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; + +use Carp; +use DB_File; +use File::Spec; +use File::Basename; +use CGI::Session::Driver; +use Fcntl qw( :DEFAULT :flock ); +use vars qw( @ISA $VERSION $FILE_NAME $UMask $NO_FOLLOW ); + +@ISA = ( "CGI::Session::Driver" ); +$VERSION = "4.20"; +$FILE_NAME = "cgisess.db"; +$UMask = 0660; +$NO_FOLLOW = eval { O_NOFOLLOW } || 0; + +sub init { + my $self = shift; + + $self->{FileName} ||= $CGI::Session::Driver::db_file::FILE_NAME; + unless ( $self->{Directory} ) { + $self->{Directory} = dirname( $self->{FileName} ); + $self->{Directory} = File::Spec->tmpdir() if $self->{Directory} eq '.' && substr($self->{FileName},0,1) ne '.'; + $self->{FileName} = basename( $self->{FileName} ); + } + unless ( -d $self->{Directory} ) { + require File::Path; + File::Path::mkpath($self->{Directory}) or return $self->set_error("init(): couldn't mkpath: $!"); + } + + $self->{UMask} = $CGI::Session::Driver::db_file::UMask unless exists $self->{UMask}; + + return 1; +} + + +sub retrieve { + my $self = shift; + my ($sid) = @_; + croak "retrieve(): usage error" unless $sid; + + return 0 unless -f $self->_db_file; + my ($dbhash, $unlock) = $self->_tie_db_file(O_RDONLY) or return; + my $datastr = $dbhash->{$sid}; + untie(%$dbhash); + $unlock->(); + return $datastr || 0; +} + + +sub store { + my $self = shift; + my ($sid, $datastr) = @_; + croak "store(): usage error" unless $sid && $datastr; + + my ($dbhash, $unlock) = $self->_tie_db_file(O_RDWR, LOCK_EX) or return; + $dbhash->{$sid} = $datastr; + untie(%$dbhash); + $unlock->(); + return 1; +} + + + +sub remove { + my $self = shift; + my ($sid) = @_; + croak "remove(): usage error" unless $sid; + + + my ($dbhash, $unlock) = $self->_tie_db_file(O_RDWR, LOCK_EX) or return; + delete $dbhash->{$sid}; + untie(%$dbhash); + $unlock->(); + return 1; +} + + +sub DESTROY {} + + +sub _lock { + my $self = shift; + my ($db_file, $lock_type) = @_; + + croak "_lock(): usage error" unless $db_file; + $lock_type ||= LOCK_SH; + + my $lock_file = $db_file . '.lck'; + if ( -l $lock_file ) { + unlink($lock_file) or + die $self->set_error("_lock(): '$lock_file' appears to be a symlink and I can't remove it: $!"); + } + sysopen(LOCKFH, $lock_file, O_RDWR|O_CREAT|$NO_FOLLOW) or die "couldn't create lock file '$lock_file': $!"; + + + flock(LOCKFH, $lock_type) or die "couldn't lock '$lock_file': $!"; + return sub { + close(LOCKFH); # && unlink($lock_file); # keep the lock file around + 1; + }; +} + + + +sub _tie_db_file { + my $self = shift; + my ($o_mode, $lock_type) = @_; + $o_mode ||= O_RDWR|O_CREAT; + + # DB_File will not touch a file unless it recognizes the format + # we can't detect the version of the underlying database without some very heavy checks so the easiest thing is + # to disable this for opening of the database + + # # protect against symlinks + # $o_mode |= $NO_FOLLOW; + + my $db_file = $self->_db_file; + my $unlock = $self->_lock($db_file, $lock_type); + my %db; + + my $create = ! -e $db_file; + + if ( -l $db_file ) { + $create = 1; + unlink($db_file) or + return $self->set_error("_tie_db_file(): '$db_file' appears to be a symlink and I can't remove it: $!"); + } + + $o_mode = O_RDWR|O_CREAT|O_EXCL if $create; + + unless( tie %db, "DB_File", $db_file, $o_mode, $self->{UMask} ){ + $unlock->(); + return $self->set_error("_tie_db_file(): couldn't tie '$db_file': $!"); + } + + return (\%db, $unlock); +} + +sub _db_file { + my $self = shift; + return File::Spec->catfile( $self->{Directory}, $self->{FileName} ); +} + +sub traverse { + my $self = shift; + my ($coderef) = @_; + + unless ( $coderef && ref($coderef) && (ref $coderef eq 'CODE') ) { + croak "traverse(): usage error"; + } + + my ($dbhash, $unlock) = $self->_tie_db_file(O_RDWR, LOCK_SH); + unless ( $dbhash ) { + return $self->set_error( "traverse(): couldn't get db handle, " . $self->errstr ); + } + while ( my ($sid, undef) = each %$dbhash ) { + $coderef->( $sid ); + } + untie(%$dbhash); + $unlock->(); + return 1; +} + + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::Driver::db_file - CGI::Session driver for BerkeleyDB using DB_File + +=head1 SYNOPSIS + + $s = new CGI::Session("driver:db_file", $sid); + $s = new CGI::Session("driver:db_file", $sid, {FileName=>'/tmp/cgisessions.db'}); + +=head1 DESCRIPTION + +B stores session data in BerkelyDB file using L - Perl module. All sessions will be stored +in a single file, specified in I driver argument as in the above example. If I isn't given, +defaults to F, or its equivalent on a non-UNIX system. + +If the directory hierarchy leading to the file does not exist, will be created for you. + +This module takes a B option which will be used if DB_File has to create the database file for you. By default +the umask is 0660. + +=head1 LICENSING + +For support and licensing information see L + +=cut + diff --git a/qooxdoo/source/perl/CGI/Session/Driver/file.pm b/qooxdoo/source/perl/CGI/Session/Driver/file.pm new file mode 100644 index 0000000..f25dfea --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Driver/file.pm @@ -0,0 +1,217 @@ +package CGI::Session::Driver::file; + +# $Id: file.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; + +use Carp; +use File::Spec; +use Fcntl qw( :DEFAULT :flock :mode ); +use CGI::Session::Driver; +use vars qw( $FileName $NoFlock $UMask $NO_FOLLOW ); + +BEGIN { + # keep historical behavior + + no strict 'refs'; + + *FileName = \$CGI::Session::File::FileName; +} + +@CGI::Session::Driver::file::ISA = ( "CGI::Session::Driver" ); +$CGI::Session::Driver::file::VERSION = "4.20"; +$FileName = "cgisess_%s"; +$NoFlock = 0; +$UMask = 0660; +$NO_FOLLOW = eval { O_NOFOLLOW } || 0; + +sub init { + my $self = shift; + $self->{Directory} ||= File::Spec->tmpdir(); + + unless ( -d $self->{Directory} ) { + require File::Path; + unless ( File::Path::mkpath($self->{Directory}) ) { + return $self->set_error( "init(): couldn't create directory path: $!" ); + } + } + + $self->{NoFlock} = $NoFlock unless exists $self->{NoFlock}; + $self->{UMask} = $UMask unless exists $self->{UMask}; + + return 1; +} + +sub _file { + my ($self,$sid) = @_; + return File::Spec->catfile($self->{Directory}, sprintf( $FileName, $sid )); +} + +sub retrieve { + my $self = shift; + my ($sid) = @_; + + my $path = $self->_file($sid); + + return 0 unless -e $path; + + # make certain our filehandle goes away when we fall out of scope + local *FH; + + if (-l $path) { + unlink($path) or + return $self->set_error("retrieve(): '$path' appears to be a symlink and I couldn't remove it: $!"); + return 0; # we deleted this so we have no hope of getting back anything + } + sysopen(FH, $path, O_RDONLY | $NO_FOLLOW ) || return $self->set_error( "retrieve(): couldn't open '$path': $!" ); + + $self->{NoFlock} || flock(FH, LOCK_SH) or return $self->set_error( "retrieve(): couldn't lock '$path': $!" ); + + my $rv = ""; + while ( ) { + $rv .= $_; + } + close(FH); + return $rv; +} + + + +sub store { + my $self = shift; + my ($sid, $datastr) = @_; + + my $path = $self->_file($sid); + + # make certain our filehandle goes away when we fall out of scope + local *FH; + + my $mode = O_WRONLY|$NO_FOLLOW; + + # kill symlinks when we spot them + if (-l $path) { + unlink($path) or + return $self->set_error("store(): '$path' appears to be a symlink and I couldn't remove it: $!"); + } + + $mode = O_RDWR|O_CREAT|O_EXCL unless -e $path; + + sysopen(FH, $path, $mode, $self->{UMask}) or return $self->set_error( "store(): couldn't open '$path': $!" ); + + # sanity check to make certain we're still ok + if (-l $path) { + return $self->set_error("store(): '$path' is a symlink, check for malicious processes"); + } + + # prevent race condition (RT#17949) + $self->{NoFlock} || flock(FH, LOCK_EX) or return $self->set_error( "store(): couldn't lock '$path': $!" ); + truncate(FH, 0) or return $self->set_error( "store(): couldn't truncate '$path': $!" ); + + print FH $datastr; + close(FH) or return $self->set_error( "store(): couldn't close '$path': $!" ); + return 1; +} + + +sub remove { + my $self = shift; + my ($sid) = @_; + + my $directory = $self->{Directory}; + my $file = sprintf( $FileName, $sid ); + my $path = File::Spec->catfile($directory, $file); + unlink($path) or return $self->set_error( "remove(): couldn't unlink '$path': $!" ); + return 1; +} + + +sub traverse { + my $self = shift; + my ($coderef) = @_; + + unless ( $coderef && ref($coderef) && (ref $coderef eq 'CODE') ) { + croak "traverse(): usage error"; + } + + opendir( DIRHANDLE, $self->{Directory} ) + or return $self->set_error( "traverse(): couldn't open $self->{Directory}, " . $! ); + + my $filename_pattern = $FileName; + $filename_pattern =~ s/\./\\./g; + $filename_pattern =~ s/\%s/(\.\+)/g; + while ( my $filename = readdir(DIRHANDLE) ) { + next if $filename =~ m/^\.\.?$/; + my $full_path = File::Spec->catfile($self->{Directory}, $filename); + my $mode = (stat($full_path))[2] + or return $self->set_error( "traverse(): stat failed for $full_path: " . $! ); + next if S_ISDIR($mode); + if ( $filename =~ /^$filename_pattern$/ ) { + $coderef->($1); + } + } + closedir( DIRHANDLE ); + return 1; +} + + +sub DESTROY { + my $self = shift; +} + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::Driver::file - Default CGI::Session driver + +=head1 SYNOPSIS + + $s = new CGI::Session(); + $s = new CGI::Session("driver:file", $sid); + $s = new CGI::Session("driver:file", $sid, {Directory=>'/tmp'}); + + +=head1 DESCRIPTION + +When CGI::Session object is created without explicitly setting I, I will be assumed. +I - driver will store session data in plain files, where each session will be stored in a separate +file. + +Naming conventions of session files are defined by C<$CGI::Session::Driver::file::FileName> global variable. +Default value of this variable is I, where %s will be replaced with respective session ID. Should +you wish to set your own FileName template, do so before requesting for session object: + + $CGI::Session::Driver::file::FileName = "%s.dat"; + $s = new CGI::Session(); + +For backwards compatibility with 3.x, you can also use the variable name +C<$CGI::Session::File::FileName>, which will override the one above. + +=head2 DRIVER ARGUMENTS + +If you wish to specify a session directory, use the B option, which denotes location of the directory +where session ids are to be kept. If B is not set, defaults to whatever File::Spec->tmpdir() returns. +So all the three lines in the SYNOPSIS section of this manual produce the same result on a UNIX machine. + +If specified B does not exist, all necessary directory hierarchy will be created. + +By default, sessions are created with a umask of 0660. If you wish to change the umask for a session, pass +a B option with an octal representation of the umask you would like for said session. + +=head1 NOTES + +If your OS doesn't support flock, you should understand the risks of going without locking the session files. Since +sessions tend to be used in environments where race conditions may occur due to concurrent access of files by +different processes, locking tends to be seen as a good and very necessary thing. If you still want to use this +driver but don't want flock, set C<$CGI::Session::Driver::file::NoFlock> to 1 or pass C<< NoFlock => 1 >> and this +driver will operate without locks. + +=head1 LICENSING + +For support and licensing see L + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/Driver/mysql.pm b/qooxdoo/source/perl/CGI/Session/Driver/mysql.pm new file mode 100644 index 0000000..4d7aaf6 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Driver/mysql.pm @@ -0,0 +1,113 @@ +package CGI::Session::Driver::mysql; + +# $Id: mysql.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; +use Carp; +use CGI::Session::Driver::DBI; + +@CGI::Session::Driver::mysql::ISA = qw( CGI::Session::Driver::DBI ); +$CGI::Session::Driver::mysql::VERSION = "4.20"; + +sub _mk_dsnstr { + my ($class, $dsn) = @_; + unless ( $class && $dsn && ref($dsn) && (ref($dsn) eq 'HASH')) { + croak "_mk_dsnstr(): usage error"; + } + + my $dsnstr = $dsn->{DataSource}; + if ( $dsn->{Socket} ) { + $dsnstr .= sprintf(";mysql_socket=%s", $dsn->{Socket}); + } + if ( $dsn->{Host} ) { + $dsnstr .= sprintf(";host=%s", $dsn->{Host}); + } + if ( $dsn->{Port} ) { + $dsnstr .= sprintf(";port=%s", $dsn->{Port}); + } + return $dsnstr; +} + + +sub init { + my $self = shift; + if ( $self->{DataSource} && ($self->{DataSource} !~ /^dbi:mysql/i) ) { + $self->{DataSource} = "dbi:mysql:database=" . $self->{DataSource}; + } + + if ( $self->{Socket} && $self->{DataSource} ) { + $self->{DataSource} .= ';mysql_socket=' . $self->{Socket}; + } + return $self->SUPER::init(); +} + +sub store { + my $self = shift; + my ($sid, $datastr) = @_; + croak "store(): usage error" unless $sid && $datastr; + + my $dbh = $self->{Handle}; + $dbh->do("REPLACE INTO " . $self->table_name . " (id, a_session) VALUES(?, ?)", undef, $sid, $datastr) + or return $self->set_error( "store(): \$dbh->do failed " . $dbh->errstr ); + return 1; +} + + +# If the table name hasn't been defined yet, check this location for 3.x compatibility +sub table_name { + my $self = shift; + unless (defined $self->{TableName}) { + $self->{TableName} = $CGI::Session::MySQL::TABLE_NAME; + } + return $self->SUPER::table_name(@_); +} + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::Driver::mysql - CGI::Session driver for MySQL database + +=head1 SYNOPSIS + + $s = new CGI::Session( "driver:mysql", $sid); + $s = new CGI::Session( "driver:mysql", $sid, { DataSource => 'dbi:mysql:test', + User => 'sherzodr', + Password => 'hello' }); + $s = new CGI::Session( "driver:mysql", $sid, { Handle => $dbh } ); + +=head1 DESCRIPTION + +B stores session records in a MySQL table. For details see L, its parent class. + +It's especially important for the MySQL driver that the session ID column be +defined as a primary key, or at least "unique", like this: + + CREATE TABLE sessions ( + id CHAR(32) NOT NULL PRIMARY KEY, + a_session TEXT NOT NULL + ); + +=head2 DRIVER ARGUMENTS + +B driver supports all the arguments documented in L. In addition, I argument can optionally leave leading "dbi:mysql:" string out: + + $s = new CGI::Session( "driver:mysql", $sid, {DataSource=>'shopping_cart'}); + # is the same as: + $s = new CGI::Session( "driver:mysql", $sid, {DataSource=>'dbi:mysql:shopping_cart'}); + +=head2 BACKWARDS COMPATIBILITY + +For backwards compatibility, you can also set the table like this before calling C. However, it is not recommended because it can cause conflicts in a persistent environment. + + $CGI::Session::MySQL::TABLE_NAME = 'my_sessions'; + +=head1 LICENSING + +For support and licensing see L. + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/Driver/postgresql.pm b/qooxdoo/source/perl/CGI/Session/Driver/postgresql.pm new file mode 100644 index 0000000..ccfdce5 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Driver/postgresql.pm @@ -0,0 +1,134 @@ +package CGI::Session::Driver::postgresql; + +# $Id: postgresql.pm 351 2006-11-24 14:16:50Z markstos $ + +# CGI::Session::Driver::postgresql - PostgreSQL driver for CGI::Session +# +# Copyright (C) 2002 Cosimo Streppone, cosimo@cpan.org +# This module is based on CGI::Session::Driver::mysql module +# by Sherzod Ruzmetov, original author of CGI::Session modules +# and CGI::Session::Driver::mysql driver. + +use strict; +use Carp "croak"; + +use CGI::Session::Driver::DBI; +use DBD::Pg qw(PG_BYTEA PG_TEXT); + +$CGI::Session::Driver::postgresql::VERSION = '4.20'; +@CGI::Session::Driver::postgresql::ISA = qw( CGI::Session::Driver::DBI ); + + +sub init { + my $self = shift; + my $ret = $self->SUPER::init(@_); + + # Translate external ColumnType into internal value. See POD for details. + $self->{PgColumnType} ||= (defined $self->{ColumnType} and (lc $self->{ColumnType} eq 'binary')) + ? PG_BYTEA + : PG_TEXT + ; + + return $ret; +} + +sub store { + my $self = shift; + my ($sid, $datastr) = @_; + croak "store(): usage error" unless $sid && $datastr; + + my $dbh = $self->{Handle}; + my $type = $self->{PgColumnType}; + + if ($type == PG_TEXT && $datastr =~ tr/\x00//) { + croak "Unallowed characters used in session data. Please see CGI::Session::Driver::postgresql ". + "for more information about null characters in text columns."; + } + + local $dbh->{RaiseError} = 1; + eval { + # There is a race condition were two clients could run this code concurrently, + # and both end up trying to insert. That's why we check for "duplicate" below + my $sth = $dbh->prepare( + "INSERT INTO " . $self->table_name . " (a_session,id) SELECT ?, ? + WHERE NOT EXISTS (SELECT 1 FROM " . $self->table_name . " WHERE id=? LIMIT 1)"); + + $sth->bind_param(1,$datastr,{ pg_type => $type }); + $sth->bind_param(2, $sid); + $sth->bind_param(3, $sid); # in the SELECT statement + my $rv = ''; + eval { $rv = $sth->execute(); }; + if ( $rv eq '0E0' or (defined $@ and $@ =~ m/duplicate/i) ) { + my $sth = $dbh->prepare("UPDATE " . $self->table_name . " SET a_session=? WHERE id=?"); + $sth->bind_param(1,$datastr,{ pg_type => $type }); + $sth->bind_param(2,$sid); + $sth->execute; + } + else { + # Nothing. Our insert has already happened + } + }; + if ($@) { + return $self->set_error( "store(): failed with message: $@ " . $dbh->errstr ); + + } + else { + return 1; + + } + + +} + +1; + +=pod + +=head1 NAME + +CGI::Session::Driver::postgresql - PostgreSQL driver for CGI::Session + +=head1 SYNOPSIS + + use CGI::Session; + $session = new CGI::Session("driver:PostgreSQL", undef, {Handle=>$dbh}); + +=head1 DESCRIPTION + +CGI::Session::PostgreSQL is a L driver to store session data in a PostgreSQL table. + +=head1 STORAGE + +Before you can use any DBI-based session drivers you need to make sure compatible database table is created for CGI::Session to work with. Following command will produce minimal requirements in most SQL databases: + + CREATE TABLE sessions ( + id CHAR(32) NOT NULL PRIMARY KEY, + a_session BYTEA NOT NULL + ); + +and within your code use: + + use CGI::Session; + $session = new CGI::Session("driver:PostgreSQL", undef, {Handle=>$dbh, ColumnType=>"binary"}); + +Please note the I argument. PostgreSQL's text type has problems when trying to hold a null character. (Known as C<"\0"> in Perl, not to be confused with SQL I). If you know there is no chance of ever having a null character in the serialized data, you can leave off the I attribute. Using a I column type and C<< ColumnType => 'binary' >> is recommended when using L as the serializer or if there's any possibility that a null value will appear in any of the serialized data. + +For more details see L, parent class. + +Also see L, which exercises different method for dealing with binary data. + +=head1 COPYRIGHT + +Copyright (C) 2002 Cosimo Streppone. All rights reserved. This library is free software and can be modified and distributed under the same terms as Perl itself. + +=head1 AUTHORS + +Cosimo Streppone , heavily based on the CGI::Session::MySQL driver by Sherzod Ruzmetov, original author of CGI::Session. + +Matt LeBlanc contributed significant updates for the 4.0 release. + +=head1 LICENSING + +For additional support and licensing see L + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/Driver/sqlite.pm b/qooxdoo/source/perl/CGI/Session/Driver/sqlite.pm new file mode 100644 index 0000000..561e9a7 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Driver/sqlite.pm @@ -0,0 +1,99 @@ +package CGI::Session::Driver::sqlite; + +# $Id: sqlite.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; + +use File::Spec; +use base 'CGI::Session::Driver::DBI'; +use DBI qw(SQL_BLOB); +use Fcntl; + +$CGI::Session::Driver::sqlite::VERSION = "4.20"; + +sub init { + my $self = shift; + + unless ( $self->{Handle}) { + $self->{DataSource} = "dbi:SQLite:dbname=" . $self->{DataSource} unless ( $self->{DataSource} =~ /^dbi:sqlite/i ); + } + + $self->SUPER::init() or return; + + $self->{Handle}->{sqlite_handle_binary_nulls} = 1; + return 1; +} + +sub store { + my $self = shift; + my ($sid, $datastr) = @_; + return $self->set_error("store(): usage error") unless $sid && $datastr; + + my $dbh = $self->{Handle}; + + my $sth = $dbh->prepare("SELECT id FROM " . $self->table_name . " WHERE id=?"); + unless ( defined $sth ) { + return $self->set_error( "store(): \$sth->prepare failed with message " . $dbh->errstr ); + } + + $sth->execute( $sid ) or return $self->set_error( "store(): \$sth->execute failed with message " . $dbh->errstr ); + if ( $sth->fetchrow_array ) { + __ex_and_ret($dbh,"UPDATE " . $self->table_name . " SET a_session=? WHERE id=?",$datastr,$sid) + or return $self->set_error( "store(): serialize to db failed " . $dbh->errstr ); + } else { + __ex_and_ret($dbh,"INSERT INTO " . $self->table_name . " (a_session,id) VALUES(?, ?)",$datastr, $sid) + or return $self->set_error( "store(): serialize to db failed " . $dbh->errstr ); + } + return 1; +} + +sub __ex_and_ret { + my ($dbh,$sql,$datastr,$sid) = @_; + # fix rt #18183 + local $@; + eval { + my $sth = $dbh->prepare($sql) or return 0; + $sth->bind_param(1,$datastr,SQL_BLOB) or return 0; + $sth->bind_param(2,$sid) or return 0; + $sth->execute() or return 0; + }; + return ! $@; +} + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::Driver::sqlite - CGI::Session driver for SQLite + +=head1 SYNOPSIS + + $s = new CGI::Session("driver:sqlite", $sid, {DataSource=>'/my/folder/sessions.sqlt'}); + $s = new CGI::Session("driver:sqlite", $sid, {Handle=>$dbh}); + +=head1 DESCRIPTION + +B driver stores session data in SQLite files using L DBI driver. More details see L, its parent class. + +=head1 DRIVER ARGUMENTS + +Supported driver arguments are I and I. B only one of these arguments can be set while creating session object. + +I should be in the form of C. If C is missing it will be prepended for you. If I is present it should be database handle (C<$dbh>) returned by L. + +As of version 1.7 of this driver, the third argument is B optional. Using a default database in the temporary directory is a security risk since anyone on the machine can create and/or read your session data. If you understand these risks and still want the old behavior, you can set the C option to I<'/tmp/sessions.sqlt'>. + +=head1 BUGS AND LIMITATIONS + +None known. + +=head1 LICENSING + +For support and licensing see L + +=cut + diff --git a/qooxdoo/source/perl/CGI/Session/ErrorHandler.pm b/qooxdoo/source/perl/CGI/Session/ErrorHandler.pm new file mode 100644 index 0000000..8f42482 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/ErrorHandler.pm @@ -0,0 +1,73 @@ +package CGI::Session::ErrorHandler; + +# $Id: ErrorHandler.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; +$CGI::Session::ErrorHandler::VERSION = "4.20"; + +=pod + +=head1 NAME + +CGI::Session::ErrorHandler - error handling routines for CGI::Session + +=head1 SYNOPSIS + + require CGI::Session::ErrorHandler + @ISA = qw( CGI::Session::ErrorHandler ); + + sub some_method { + my $self = shift; + unless ( $some_condition ) { + return $self->set_error("some_method(): \$some_condition isn't met"); + } + } + +=head1 DESCRIPTION + +CGI::Session::ErrorHandler provides set_error() and errstr() methods for setting and accessing error messages from within CGI::Session's components. This method should be used by driver developers for providing CGI::Session-standard error handling routines for their code + +=head2 METHODS + +=over 4 + +=item set_error($message) + +Implicitly defines $pkg_name::errstr and sets its value to $message. Return value is B undef. + +=cut + +sub set_error { + my $class = shift; + my $message = shift; + $class = ref($class) || $class; + no strict 'refs'; + ${ "$class\::errstr" } = sprintf($message || "", @_); + return; +} + +=item errstr() + +Returns whatever value was set by the most recent call to set_error(). If no message as has been set yet, the empty string is returned so the message can still concatenate without a warning. + +=back + +=cut + +*error = \&errstr; +sub errstr { + my $class = shift; + $class = ref( $class ) || $class; + + no strict 'refs'; + return ${ "$class\::errstr" } || ''; +} + +=head1 LICENSING + +For support and licensing information see L. + +=cut + +1; + diff --git a/qooxdoo/source/perl/CGI/Session/ID/incr.pm b/qooxdoo/source/perl/CGI/Session/ID/incr.pm new file mode 100644 index 0000000..75324b5 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/ID/incr.pm @@ -0,0 +1,77 @@ +package CGI::Session::ID::incr; + +# $Id: incr.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; +use File::Spec; +use Carp "croak"; +use Fcntl qw( :DEFAULT :flock ); +use CGI::Session::ErrorHandler; + +$CGI::Session::ID::incr::VERSION = '4.20'; +@CGI::Session::ID::incr::ISA = qw( CGI::Session::ErrorHandler ); + + +sub generate_id { + my ($self, $args) = @_; + + my $IDFile = $args->{IDFile} or croak "Don't know where to store the id"; + my $IDIncr = $args->{IDIncr} || 1; + my $IDInit = $args->{IDInit} || 0; + + sysopen(FH, $IDFile, O_RDWR|O_CREAT, 0666) or return $self->set_error("Couldn't open IDFile=>$IDFile: $!"); + flock(FH, LOCK_EX) or return $self->set_error("Couldn't lock IDFile=>$IDFile: $!"); + my $ID = || $IDInit; + seek(FH, 0, 0) or return $self->set_error("Couldn't seek IDFile=>$IDFile: $!"); + truncate(FH, 0) or return $self->set_error("Couldn't truncate IDFile=>$IDFile: $!"); + $ID += $IDIncr; + print FH $ID; + close(FH) or return $self->set_error("Couldn't close IDFile=>$IDFile: $!"); + return $ID; +} + + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::ID::incr - CGI::Session ID driver + +=head1 SYNOPSIS + + use CGI::Session; + $session = new CGI::Session("id:Incr", undef, { + Directory => '/tmp', + IDFile => '/tmp/cgisession.id', + IDInit => 1000, + IDIncr => 2 }); + +=head1 DESCRIPTION + +CGI::Session::ID::incr is to generate auto incrementing Session IDs. Compare it with L, where session ids are truly random 32 character long strings. CGI::Session::ID::incr expects the following arguments passed to CGI::Session->new() as the third argument. + +=over 4 + +=item IDFile + +Location where auto incremented IDs are stored. This attribute is required. + +=item IDInit + +Initial value of the ID if it's the first ID to be generated. For example, if you want the ID numbers to start with 1000 as opposed to 0, that's where you should set your value. Default is C<0>. + +=item IDIncr + +How many digits each number should increment by. For example, if you want the first generated id to start with 1000, and each subsequent id to increment by 10, set I to 10 and I to 1000. Default is C<1>. + +=back + +=head1 LICENSING + +For support and licensing information see L + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/ID/md5.pm b/qooxdoo/source/perl/CGI/Session/ID/md5.pm new file mode 100644 index 0000000..82864e0 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/ID/md5.pm @@ -0,0 +1,41 @@ +package CGI::Session::ID::md5; + +# $Id: md5.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; +use Digest::MD5; +use CGI::Session::ErrorHandler; + +$CGI::Session::ID::md5::VERSION = '4.20'; +@CGI::Session::ID::md5::ISA = qw( CGI::Session::ErrorHandler ); + +*generate = \&generate_id; +sub generate_id { + my $md5 = new Digest::MD5(); + $md5->add($$ , time() , rand(time) ); + return $md5->hexdigest(); +} + + +1; + +=pod + +=head1 NAME + +CGI::Session::ID::md5 - default CGI::Session ID generator + +=head1 SYNOPSIS + + use CGI::Session; + $s = new CGI::Session("id:md5", undef); + +=head1 DESCRIPTION + +CGI::Session::ID::MD5 is to generate MD5 encoded hexadecimal random ids. The library does not require any arguments. + +=head1 LICENSING + +For support and licensing see L + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/ID/static.pm b/qooxdoo/source/perl/CGI/Session/ID/static.pm new file mode 100644 index 0000000..b77dde4 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/ID/static.pm @@ -0,0 +1,55 @@ +package CGI::Session::ID::static; + +# $Id: static.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; +use Carp ("croak"); +use CGI::Session::ErrorHandler; + +$CGI::Session::ID::static::VERSION = '4.20'; +@::CGI::Session::ID::static::ISA = qw( CGI::Session::ErrorHandler ); + +sub generate_id { + my ($self, $args, $claimed_id ) = @_; + unless ( defined $claimed_id ) { + croak "'CGI::Session::ID::Static::generate_id()' requires static id"; + } + return $claimed_id; +} + +1; +__END__ + +=head1 NAME + +CGI::Session::ID::static - CGI::Session ID Driver for generating static IDs + +=head1 SYNOPSIS + + use CGI::Session; + $session = new CGI::Session("id:static", $ENV{REMOTE_ADDR}); + +=head1 DESCRIPTION + +CGI::Session::ID::static is used to generate consistent, static session +ID's. In other words, you tell CGI::Session ID you want to use, and it will honor it. + +Unlike the other ID drivers, this one requires that you provide an ID when creating +the session object; if you pass it an undefined value, it will croak. + +=head1 COPYRIGHT + +Copyright (C) 2002 Adam Jacob , + +This library is free software. You can modify and distribute it under the same +terms as Perl itself. + +=head1 AUTHORS + +Adam Jacob , + +=head1 LICENSING + +For additional support and licensing see L + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/Serialize/default.pm b/qooxdoo/source/perl/CGI/Session/Serialize/default.pm new file mode 100644 index 0000000..a18c164 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Serialize/default.pm @@ -0,0 +1,139 @@ +package CGI::Session::Serialize::default; + +# $Id: default.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; +use Safe; +use Data::Dumper; +use CGI::Session::ErrorHandler; +use Scalar::Util qw(blessed reftype refaddr); +use Carp "croak"; +use vars qw( %overloaded ); +require overload; + +@CGI::Session::Serialize::default::ISA = ( "CGI::Session::ErrorHandler" ); +$CGI::Session::Serialize::default::VERSION = '4.20'; + + +sub freeze { + my ($class, $data) = @_; + + my $d = + new Data::Dumper([$data], ["D"]); + $d->Indent( 0 ); + $d->Purity( 1 ); + $d->Useqq( 0 ); + $d->Deepcopy( 0 ); + $d->Quotekeys( 1 ); + $d->Terse( 0 ); + + # ;$D added to make certain we get our data structure back when we thaw + return $d->Dump() . ';$D'; +} + +sub thaw { + my ($class, $string) = @_; + + # To make -T happy + my ($safe_string) = $string =~ m/^(.*)$/s; + my $rv = Safe->new->reval( $safe_string ); + if ( $@ ) { + return $class->set_error("thaw(): couldn't thaw. $@"); + } + __walk($rv); + return $rv; +} + +sub __walk { + my %seen; + my @filter = __scan(shift); + local %overloaded; + + while (defined(my $x = shift @filter)) { + $seen{refaddr $x || ''}++ and next; + + my $r = reftype $x or next; + if ($r eq "HASH") { + # we use this form to make certain we have aliases + # to the values in %$x and not copies + push @filter, __scan(@{$x}{keys %$x}); + } elsif ($r eq "ARRAY") { + push @filter, __scan(@$x); + } elsif ($r eq "SCALAR" || $r eq "REF") { + push @filter, __scan($$x); + } + } +} + +# we need to do this because the values we get back from the safe compartment +# will have packages defined from the safe compartment's *main instead of +# the one we use +sub __scan { + # $_ gets aliased to each value from @_ which are aliases of the values in + # the current data structure + for (@_) { + if (blessed $_) { + if (overload::Overloaded($_)) { + my $address = refaddr $_; + + # if we already rebuilt and reblessed this item, use the cached + # copy so our ds is consistent with the one we serialized + if (exists $overloaded{$address}) { + $_ = $overloaded{$address}; + } else { + my $reftype = reftype $_; + if ($reftype eq "HASH") { + $_ = $overloaded{$address} = bless { %$_ }, ref $_; + } elsif ($reftype eq "ARRAY") { + $_ = $overloaded{$address} = bless [ @$_ ], ref $_; + } elsif ($reftype eq "SCALAR" || $reftype eq "REF") { + $_ = $overloaded{$address} = bless \do{my $o = $$_},ref $_; + } else { + croak "Do not know how to reconstitute blessed object of base type $reftype"; + } + } + } else { + bless $_, ref $_; + } + } + } + return @_; +} + + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::Serialize::default - Default CGI::Session serializer + +=head1 DESCRIPTION + +This library is used by CGI::Session driver to serialize session data before storing it in disk. + +All the methods are called as class methods. + +=head1 METHODS + +=over 4 + +=item freeze($class, \%hash) + +Receives two arguments. First is the class name, the second is the data to be serialized. Should return serialized string on success, undef on failure. Error message should be set using C + +=item thaw($class, $string) + +Received two arguments. First is the class name, second is the I data string. Should return thawed data structure on success, undef on failure. Error message should be set using C + +=back + +=head1 LICENSING + +For support and licensing see L + +=cut + diff --git a/qooxdoo/source/perl/CGI/Session/Serialize/freezethaw.pm b/qooxdoo/source/perl/CGI/Session/Serialize/freezethaw.pm new file mode 100644 index 0000000..c71ece8 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Serialize/freezethaw.pm @@ -0,0 +1,55 @@ +package CGI::Session::Serialize::freezethaw; + +# $Id: freezethaw.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; +use FreezeThaw; +use CGI::Session::ErrorHandler; + +$CGI::Session::Serialize::freezethaw::VERSION = 4.2; +@CGI::Session::Serialize::freezethaw::ISA = ( "CGI::Session::ErrorHandler" ); + +sub freeze { + my ($self, $data) = @_; + return FreezeThaw::freeze($data); +} + + +sub thaw { + my ($self, $string) = @_; + return (FreezeThaw::thaw($string))[0]; +} + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::Serialize::freezethaw - serializer for CGI::Session + +=head1 DESCRIPTION + +This library can be used by CGI::Session to serialize session data. Uses L. + +=head1 METHODS + +=over 4 + +=item freeze($class, \%hash) + +Receives two arguments. First is the class name, the second is the data to be serialized. Should return serialized string on success, undef on failure. Error message should be set using C + +=item thaw($class, $string) + +Received two arguments. First is the class name, second is the I data string. Should return thawed data structure on success, undef on failure. Error message should be set using C + +=back + +=head1 LICENSING + +For support and licensing see L + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/Serialize/json.pm b/qooxdoo/source/perl/CGI/Session/Serialize/json.pm new file mode 100644 index 0000000..2f8c8bb --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Serialize/json.pm @@ -0,0 +1,64 @@ +package CGI::Session::Serialize::json; + +use strict; +use CGI::Session::ErrorHandler; + +$CGI::Session::Serialize::json::VERSION = '4.20'; +@CGI::Session::Serialize::json::ISA = ( "CGI::Session::ErrorHandler" ); +our $Flavour; + +unless($Flavour) { + my $package = (grep { eval("use $_ (); 1;") } qw(JSON::Syck))[0] + or die "JSON::Syck is required to use ", __PACKAGE__; + $Flavour = $package; +} + +sub freeze { + my ($self, $data) = @_; + return $Flavour->can('Dump')->($data); +} + + +sub thaw { + my ($self, $string) = @_; + return ($Flavour->can('Load')->($string))[0]; +} + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::Serialize::json - serializer for CGI::Session + +=head1 DESCRIPTION + +This library can be used by CGI::Session to serialize session data. Requires +L. JSON is a type of L, +with one extension: serialized JSON strings are actually valid JavaScript +code that a browser can execute. Any langauge that has a YAML parser +(Perl, PHP, Python, Ruby, C, etc) can also read data that has been serialized +with JSON. + +=head1 METHODS + +=over 4 + +=item freeze($class, \%hash) + +Receives two arguments. First is the class name, the second is the data to be serialized. Should return serialized string on success, undef on failure. Error message should be set using C + +=item thaw($class, $string) + +Received two arguments. First is the class name, second is the I data string. Should return thawed data structure on success, undef on failure. Error message should be set using C + +=back + +=head1 SEE ALSO + +L, L. + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/Serialize/storable.pm b/qooxdoo/source/perl/CGI/Session/Serialize/storable.pm new file mode 100644 index 0000000..6ac2dae --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Serialize/storable.pm @@ -0,0 +1,60 @@ +package CGI::Session::Serialize::storable; + +# $Id: storable.pm 351 2006-11-24 14:16:50Z markstos $ + +use strict; +use Storable; +require CGI::Session::ErrorHandler; + +$CGI::Session::Serialize::storable::VERSION = "4.20"; +@CGI::Session::Serialize::ISA = ( "CGI::Session::ErrorHandler" ); + +=pod + +=head1 NAME + +CGI::Session::Serialize::storable - Serializer for CGI::Session + +=head1 DESCRIPTION + +This library can be used by CGI::Session to serialize session data. Uses L. + +=head1 METHODS + +=over 4 + +=item freeze($class, \%hash) + +Receives two arguments. First is the class name, the second is the data to be serialized. +Should return serialized string on success, undef on failure. Error message should be set using +C + +=cut + +sub freeze { + my ($self, $data) = @_; + return Storable::freeze($data); +} + +=item thaw($class, $string) + +Receives two arguments. First is the class name, second is the I data string. Should return +thawed data structure on success, undef on failure. Error message should be set +using C + +=back + +=cut + +sub thaw { + my ($self, $string) = @_; + return Storable::thaw($string); +} + +=head1 LICENSING + +For support and licensing see L + +=cut + +1; diff --git a/qooxdoo/source/perl/CGI/Session/Serialize/yaml.pm b/qooxdoo/source/perl/CGI/Session/Serialize/yaml.pm new file mode 100644 index 0000000..fd276d8 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Serialize/yaml.pm @@ -0,0 +1,67 @@ +package CGI::Session::Serialize::yaml; + +use strict; +use CGI::Session::ErrorHandler; + +$CGI::Session::Serialize::yaml::VERSION = '4.20'; +@CGI::Session::Serialize::yaml::ISA = ( "CGI::Session::ErrorHandler" ); +our $Flavour; + +unless($Flavour) { + my $package = (grep { eval("use $_ (); 1;") } qw(YAML::Syck YAML))[0] + or die "Either YAML::Syck or YAML are required to use ", __PACKAGE__; + $Flavour = $package; +} + +sub freeze { + my ($self, $data) = @_; + return $Flavour->can('Dump')->($data); +} + + +sub thaw { + my ($self, $string) = @_; + return ($Flavour->can('Load')->($string))[0]; +} + +1; + +__END__; + +=pod + +=head1 NAME + +CGI::Session::Serialize::yaml - serializer for CGI::Session + +=head1 DESCRIPTION + +This library can be used by CGI::Session to serialize session data. It uses +L, or the faster C implementation, L +if it is available. YAML serializers exist not just for Perl but also other +dynamic languages, such as PHP, Python, and Ruby, so storing session data +in this format makes it easy to share session data across different languages. + +YAML is made to be friendly for humans to parse as well as other computer +languages. It creates a format that is easier to read than the default +serializer. + +=head1 METHODS + +=over 4 + +=item freeze($class, \%hash) + +Receives two arguments. First is the class name, the second is the data to be serialized. Should return serialized string on success, undef on failure. Error message should be set using C + +=item thaw($class, $string) + +Received two arguments. First is the class name, second is the I data string. Should return thawed data structure on success, undef on failure. Error message should be set using C + +=back + +=head1 SEE ALSO + +L, L, L. + +=cut diff --git a/qooxdoo/source/perl/CGI/Session/Test/Default.pm b/qooxdoo/source/perl/CGI/Session/Test/Default.pm new file mode 100644 index 0000000..5eca1a3 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Test/Default.pm @@ -0,0 +1,426 @@ +package CGI::Session::Test::Default; + +use strict; +use Carp; +use Test::More (); +use Data::Dumper; +use Scalar::Util "refaddr"; + +our $AUTOLOAD; +our $CURRENT; +sub ok_later (&;$); + + +$CGI::Session::Test::Default::VERSION = '4.20'; + +=head1 CGI::Session::Test::Default + +Run a suite of tests for a given CGI::Session::Driver + +=head2 new() + + my $t = CGI::Session::Test::Default->new( + # These are all optional, with default as follows + dsn => "driver:file", + args => undef, + tests => 77, + ); + +Create a new test object, possibly overriding some defaults. + +=cut + +sub new { + my $class = shift; + my $self = bless { + dsn => "driver:file", + args => undef, + tests => 101, + test_number => 0, + @_ + }, $class; + + if($self->{skip}) { + $self->{_skip} = { map { $_ => $_ } @{$self->{skip}} }; + } else { + $self->{_skip} = {}; + } + + return $self; +} + +=head2 number_of_tests() + + my $new_num = $t->number_of_tests($new_num); + +A setter/accessor method to affect the number of tests to run, +after C has been called and before C. + +=cut + +sub number_of_tests { + my $self = shift; + + if ( @_ ) { + $self->{tests} = $_[0]; + } + + return $self->{tests}; +} + +=head2 run() + + $t->run(); + +Run the test suite. See C for setting related options. + +=cut + +sub run { + my $self = shift; + + $CURRENT = $self; + use_ok("CGI::Session", "CGI::Session loaded successfully!"); + + my $sid = undef; + FIRST: { + ok(1, "=== 1 ==="); + my $session = CGI::Session->load() or die CGI::Session->errstr; + ok($session, "empty session should be created"); + ok(!$session->id); + ok($session->is_empty); + ok(!$session->is_expired); + + undef $session; + + $session = CGI::Session->new($self->{dsn}, '_DOESN\'T EXIST_', $self->{args}) or die CGI::Session->errstr; + ok( $session, "Session created successfully!"); + + # + # checking if the driver object created is really the driver requested: + # + my $dsn = $session->parse_dsn( $self->{dsn} ); + ok( ref $session->_driver eq "CGI::Session::Driver::" . $dsn->{driver}, ref $dsn->{Driver} ); + + ok( $session->ctime && $session->atime, "ctime & atime are set"); + ok( $session->atime == $session->ctime, "ctime == atime"); + ok( !$session->etime, "etime not set yet"); + + ok( $session->id, "session id is " . $session->id); + + $session->param('author', "Sherzod Ruzmetov"); + $session->param(-name=>'emails', -value=>['sherzodr@cpan.org', 'sherzodr@handalak.com']); + $session->param('blogs', { + './lost+found' => 'http://author.handalak.com/', + 'Yigitlik sarguzashtlari' => 'http://author.handalak.com/uz/' + }); + + ok( ($session->param) == 3, "session holds 3 params" . scalar $session->param ); + ok( $session->param('author') eq "Sherzod Ruzmetov", "My name's correct!"); + + ok( ref ($session->param('emails')) eq 'ARRAY', "'emails' holds list of values" ); + ok( @{ $session->param('emails') } == 2, "'emails' holds list of two values"); + ok( $session->param('emails')->[0] eq 'sherzodr@cpan.org', "first value of 'emails' is correct!"); + ok( $session->param('emails')->[1] eq 'sherzodr@handalak.com', "second value of 'emails' is correct!"); + + ok( ref( $session->param('blogs') ) eq 'HASH', "'blogs' holds a hash"); + ok( $session->param('blogs')->{'./lost+found'} eq 'http://author.handalak.com/', "first blog is correct"); + ok( $session->param('blogs')->{'Yigitlik sarguzashtlari'} eq 'http://author.handalak.com/uz/', "second blog is correct"); + + $sid = $session->id; + $session->flush(); + } + + sleep(1); + + SECOND: { + SKIP: { + ok(1, "=== 2 ==="); + my $session; + eval { $session = CGI::Session->load($self->{dsn}, $sid, $self->{args}) }; + + if ($@ || CGI::Session->errstr) { + Test::More::skip("couldn't load session, bailing out: SQLite/Storable support is TODO", 56); + } + + is($@.CGI::Session->errstr,'','survived eval without error.'); + ok($session, "Session was retrieved successfully"); + ok(!$session->is_expired, "session isn't expired yet"); + + is($session->id,$sid, "session IDs are consistent"); + ok($session->atime > $session->ctime, "ctime should be older than atime"); + ok(!$session->etime, "etime shouldn't be set yet"); + + ok( ($session->param) == 3, "session should hold params" ); + ok( $session->param('author') eq "Sherzod Ruzmetov", "my name's correct"); + + ok( ref ($session->param('emails')) eq 'ARRAY', "'emails' should hold list of values" ); + ok( @{ $session->param('emails') } == 2, "'emails' should hold list of two values"); + ok( $session->param('emails')->[0] eq 'sherzodr@cpan.org', "first value is correct!"); + ok( $session->param('emails')->[1] eq 'sherzodr@handalak.com', "second value is correct!"); + + ok( ref( $session->param('blogs') ) eq 'HASH', "'blogs' holds a hash"); + ok( $session->param('blogs')->{'./lost+found'} eq 'http://author.handalak.com/', "first blog is correct!"); + ok( $session->param('blogs')->{'Yigitlik sarguzashtlari'} eq 'http://author.handalak.com/uz/', "second blog is correct!"); + + # TODO: test many any other variations of expire() syntax + $session->expire('+1s'); + ok($session->etime == 1, "etime set to 1 second"); + + $session->expire("+1m"); + ok($session->etime == 60, "etime set to one minute"); + + $session->expires("2h"); + ok($session->etime == 7200, "etime set to two hours"); + + $session->expires("5d"); + ok($session->etime == 432000, "etime set to 5 days"); + + $session->expires("-10s"); + ok($session->etime == -10, "etime set to 10 seconds in the past"); + + # + # Setting the expiration time back to 1s, so that subsequent tests + # relying on this value pass + # + $session->expire("1s"); + ok($session->etime == 1, "etime set back to one second"); + eval { $session->close(); }; + is($@, '', 'calling close method survives eval'); + } + } + + sleep(1); # <-- letting the time tick + + my $driver; + THREE: { + ok(1, "=== 3 ==="); + my $session = CGI::Session->load($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr; + ok($session, "Session instance loaded "); + ok(!$session->id, "session doesn't have ID"); + ok($session->is_empty, "session is empty, which is the same as above"); + #print $session->dump; + ok($session->is_expired, "session was expired"); + ok(!$session->param('author'), "session data cleared"); + + sleep(1); + + $session = $session->new() or die CGI::Session->errstr; + #print $session->dump(); + ok($session, "new session created"); + ok($session->id, "session has id :" . $session->id ); + ok(!$session->is_expired, "session isn't expired"); + ok(!$session->is_empty, "session isn't empty"); + ok($session->atime == $session->ctime, "access and creation times are same"); + + ok($session->id ne $sid, "it's a completely different session than above"); + + $driver = $session->_driver(); + $sid = $session->id; + } + + + + FOUR: { + # We are intentionally removing the session stored in the datastore and will be requesting + # re-initialization of that id. This test is necessary since I noticed weird behaviors in + # some of my web applications that kept creating new sessions when the object requested + # wasn't in the datastore. + ok(1, "=== 4 ==="); + + ok($driver->remove( $sid ), "Session '$sid' removed from datastore successfully"); + + my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args} ) or die CGI::Session->errstr; + ok($session, "session object created successfully"); + ok($session->id ne $sid, "claimed ID ($sid) couldn't be recovered. New ID is: " . $session->id); + $sid = $session->id; + } + + + + FIVE: { + ok(1, "=== 5 ==="); + my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr; + ok($session, "Session object created successfully"); + ok($session->id eq $sid, "claimed id ($sid) was recovered successfully!"); + + # Remove the object, finally! + $session->delete(); + } + + + SIX: { + ok(1, "=== 6 ==="); + my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr; + ok($session, "Session object created successfully"); + ok($session->id ne $sid, "New object created, because previous object was deleted"); + $sid = $session->id; + + # + # creating a simple object to be stored into session + my $simple_class = SimpleObjectClass->new(); + ok($simple_class, "SimpleObjectClass created successfully"); + + $simple_class->name("Sherzod Ruzmetov"); + $simple_class->emails(0, 'sherzodr@handalak.com'); + $simple_class->emails(1, 'sherzodr@cpan.org'); + $simple_class->blogs('lost+found', 'http://author.handalak.com/'); + $simple_class->blogs('yigitlik', 'http://author.handalak.com/uz/'); + $session->param('simple_object', $simple_class); + + ok($session->param('simple_object')->name eq "Sherzod Ruzmetov"); + ok($session->param('simple_object')->emails(1) eq 'sherzodr@cpan.org'); + ok($session->param('simple_object')->blogs('yigitlik') eq 'http://author.handalak.com/uz/'); + + # + # creating an overloaded object to be stored into session + my $overloaded_class = OverloadedObjectClass->new("ABCDEFG"); + ok($overloaded_class, "OverloadedObjectClass created successfully"); + ok(overload::Overloaded($overloaded_class) , "OverloadedObjectClass is properly overloaded"); + ok(ref ($overloaded_class) eq "OverloadedObjectClass", "OverloadedObjectClass is an object"); + $session->param("overloaded_object", $overloaded_class); + + ok($session->param("overloaded_object") eq "ABCDEFG"); + + my $simple_class2 = SimpleObjectClass->new(); + ok($simple_class2, "SimpleObjectClass created successfully"); + + $simple_class2->name("Sherzod Ruzmetov"); + $simple_class2->emails(0, 'sherzodr@handalak.com'); + $simple_class2->emails(1, 'sherzodr@cpan.org'); + $simple_class2->blogs('lost+found', 'http://author.handalak.com/'); + $simple_class2->blogs('yigitlik', 'http://author.handalak.com/uz/'); + my $embedded = OverloadedObjectClass->new("Embedded"); + $session->param("embedded_simple_and_overloaded",[ undef, $simple_class2, $embedded, $embedded ]); + + ok(!defined($session->param("embedded_simple_and_overloaded")->[0]),"First element of anonymous array undef"); + + ok($session->param("embedded_simple_and_overloaded")->[1]->name eq "Sherzod Ruzmetov"); + ok($session->param("embedded_simple_and_overloaded")->[1]->emails(1) eq 'sherzodr@cpan.org'); + ok($session->param("embedded_simple_and_overloaded")->[1]->blogs('yigitlik') eq 'http://author.handalak.com/uz/'); + + ok($session->param("embedded_simple_and_overloaded")->[2] eq "Embedded"); + + ok(refaddr($session->param("embedded_simple_and_overloaded")->[2]) == refaddr($session->param("embedded_simple_and_overloaded")->[3] ), + "Overloaded objects have matching addresses"); + } + + + SEVEN: { + ok(1, "=== 7 ==="); + my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr; + ok($session, "Session object created successfully"); + ok($session->id eq $sid, "Previously stored object loaded successfully"); + + + my $simple_object = $session->param("simple_object"); + ok(ref $simple_object eq "SimpleObjectClass", "SimpleObjectClass loaded successfully"); + + my $dsn = CGI::Session->parse_dsn($self->{dsn}); + ok_later { $simple_object->name eq "Sherzod Ruzmetov" }; + ok_later { $simple_object->emails(1) eq 'sherzodr@cpan.org' }; + ok_later { $simple_object->emails(0) eq 'sherzodr@handalak.com' }; + ok_later { $simple_object->blogs('lost+found') eq 'http://author.handalak.com/' }; + ok(ref $session->param("overloaded_object") ); + ok($session->param("overloaded_object") eq "ABCDEFG", "Object is still overloaded"); + ok(overload::Overloaded($session->param("overloaded_object")), "Object is really overloaded"); + + ok(!defined($session->param("embedded_simple_and_overloaded")->[0]),"First element of anonymous array undef"); + + my $simple_object2 = $session->param("embedded_simple_and_overloaded")->[1]; + ok(ref $simple_object2 eq "SimpleObjectClass", "SimpleObjectClass loaded successfully"); + + ok_later { $simple_object2->name eq "Sherzod Ruzmetov" }; + ok_later { $simple_object2->emails(1) eq 'sherzodr@cpan.org' }; + ok_later { $simple_object2->emails(0) eq 'sherzodr@handalak.com' }; + ok_later { $simple_object2->blogs('lost+found') eq 'http://author.handalak.com/' }; + + + ok($session->param("embedded_simple_and_overloaded")->[2] eq "Embedded"); + ok(overload::Overloaded($session->param("embedded_simple_and_overloaded")->[2]), "Object is really overloaded"); + + ok(refaddr($session->param("embedded_simple_and_overloaded")->[2]) == refaddr($session->param("embedded_simple_and_overloaded")->[3]), + "Overloaded objects have matching addresses"); + $session->delete(); + } + + $CURRENT = undef; + $self->{test_number} = 0; +} + +sub skip_or_run { + my $test = shift; + + $CURRENT->{test_number} ++; + + SKIP: { + if($CURRENT->{_skip}->{$CURRENT->{test_number}}) { + Test::More::skip("Test does not apply to this setup.", 1); + } + + no strict 'refs'; + &{"Test::More::$test"}(@_); + } +} + +sub ok { skip_or_run("ok", @_); } +sub use_ok { skip_or_run("use_ok", @_); } +sub is { skip_or_run("is", @_); } + +sub ok_later (&;$) { + my($code, $name) = @_; + + $CURRENT->{test_number} ++; + $name = '' unless $name; + + SKIP: { + if($CURRENT->{_skip}->{$CURRENT->{test_number}}) { + Test::More::skip("Test does not apply to this setup.", 1); + fail($name); + } else { + Test::More::ok($code->(), $name); + } + } +} + +sub DESTROY { 1; } + + +package SimpleObjectClass; +use strict; +use Class::Struct; + +struct ( + name => '$', + emails => '@', + blogs => '%' +); + + + +package OverloadedObjectClass; + +use strict; +use overload ( + '""' => \&as_string, + 'eq' => \&equals +); + +sub new { + return bless { + str_value => $_[1] + }, $_[0]; +} + + +sub as_string { + return $_[0]->{str_value}; +} + +sub equals { + my ($self, $arg) = @_; + + return ($self->as_string eq $arg); +} + +1; diff --git a/qooxdoo/source/perl/CGI/Session/Tutorial.pm b/qooxdoo/source/perl/CGI/Session/Tutorial.pm new file mode 100644 index 0000000..9b21dc3 --- /dev/null +++ b/qooxdoo/source/perl/CGI/Session/Tutorial.pm @@ -0,0 +1,357 @@ +package CGI::Session::Tutorial; + +# $Id: Tutorial.pm 351 2006-11-24 14:16:50Z markstos $ + +$CGI::Session::Tutorial::VERSION = '4.20'; + +=pod + +=head1 NAME + +CGI::Session::Tutorial - Extended CGI::Session manual + +=head1 STATE MAINTENANCE OVERVIEW + +Since HTTP is a stateless protocol, each subsequent click to a web site is treated as new request by the Web server. The server does not relate a visit with a previous one, thus all the state information from the previous requests are lost. This makes creating such applications as shopping carts, web sites requiring users to authenticate, impossible. So people had to do something about this despair situation HTTP was putting us in. + +For our rescue come such technologies as I and Is that help us save the users' session for a certain period. Since I and Is alone cannot take us too far (B), several other libraries have been developed to extend their capabilities and promise a more reliable solution. L is one of them. + +Before we discuss this library, let's look at some alternative solutions. + +=head2 COOKIE + +Cookie is a piece of text-information that a web server is entitled to place in the user's hard disk, assuming a user agent (such as Internet Explorer, Mozilla, etc) is compatible with the specification. After the cookie is placed, user agents are required to send these cookies back to the server as part of the HTTP request. This way the server application ( CGI, for example ) will have a way of relating previous requests by the same user agent, thus overcoming statelessness of HTTP. + +Although I seem to be promising solution for the statelessness of HTTP, they do carry certain limitations, such as limited number of cookies per domain and per user agent and limited size on each cookie. User Agents are required to store at least 300 cookies at a time, 20 cookies per domain and allow 4096 bytes of storage for each cookie. They also rise several Privacy and Security concerns, the lists of which can be found on the sections B<6-"Privacy"> and B<7-"Security Considerations"> of B. + +=head2 QUERY STRING + +Query string is a string appended to URL following a question mark (?) such as: + + http://my.dot.com/login.cgi?user=sherzodr;password=top-secret + +As you probably guessed, it can also help you pass state information from a click to another, but how secure is it do you think, considering these URLs tend to get cached by most of the user agents and also logged in the servers access log, to which everyone can have access. + +=head2 HIDDEN FIELDS + +Hidden field is another alternative to using query strings and they come in two flavors: hidden fields used in POST methods and the ones in GET. The ones used in GET methods will turn into a true query strings once submitted, so all the disadvantages of QUERY_STRINGs apply. Although POST requests do not have limitations of its sister-GET, the pages that hold them get cached by Web browser, and are available within the source code of the page (obviously). They also become unwieldily to manage when one has oodles of state information to keep track of ( for instance, a shopping cart or an advanced search engine). + +Query strings and hidden fields are also lost easily by closing the browser, or by clicking the browser's "Back" button. + +=head2 SERVER SIDE SESSION MANAGEMENT + +This technique is built upon the aforementioned technologies plus a server-side storage device, which saves the state data on the server side. Each session has a unique id associated with the data in the server. This id is also associated with the user agent either in the form of a I, a I, hidden field or any combination of the above. This is necessary to make the connection with the client and his data. + +Advantages: + +=over 4 + +=item * + +We no longer need to depend on User Agent constraints in cookie size. + +=item * + +Sensitive data no longer need to be traveling across the network at each request (which is the case with query strings, cookies and hidden fields). The only thing that travels is the unique id generated for the session (B<5767393932698093d0b75ef614376314>, for instance), which should make no sense to third parties. + +=item * + +User will not have sensitive data stored in his/her computer in unsecured file (which is a cookie file). + +=item * + +It's possible to handle very big and even complex data structures transparently (which I do not handle). + +=back + +That's what CGI::Session is all about - implementing server side session management. Now is a good time to get feet wet. + +=head1 PROGRAMMING STYLE + +Server side session management system might be seeming awfully convoluted if you have never dealt with it. Fortunately, with L all the complexity is handled by the library transparently. This section of the manual can be treated as an introductory tutorial to both logic behind session management, and to CGI::Session programming style. + +All applications making use of server side session management rely on the following pattern of operation regardless of the way the system is implemented: + +=over 4 + +=item 1 + +Check if the user has session cookie dropped in his computer from previous request + +=item 2 + +If the cookie does not exist, create a new session identifier, and drop it as cookie to the user's computer. + +=item 3 + +If session cookie exists, read the session ID from the cookie and load any previously saved session data from the server side storage. If session had any expiration date set it's useful to re-drop the same cookie to the user's computer so its expiration time will be reset to be relative to user's last activity time. + +=item 4 + +Store any necessary data in the session that you want to make available for the next HTTP request. + +=back + +CGI::Session will handle all of the above steps. All you have to do is to choose what to store in the session. + +=head2 GETTING STARTED + +To make L's functionality available in your program do either of the following somewhere on top of your program file: + + use CGI::Session; + # or + require CGI::Session; + +Whenever you're ready to create a new session in your application, do the following: + + $session = new CGI::Session() or die CGI::Session->errstr; + +Above line will first try to re-initialize an existing session by consulting cookies and necessary QUERY_STRING parameters. If it fails will create a brand new session with a unique ID, which is normally called I, I for short, and can be accessed through L - object method. + +We didn't check for any session cookies above, did we? No, we didn't, but CGI::Session did. It looked for a cookie called C, and if it found it tried to load existing session from server side storage (B in our case). If cookie didn't exist it looked for a QUERY_STRING parameter called C. If all the attempts to recover session ID failed, it created a new session. + +NOTE: For the above syntax to work as intended your application needs to have write access to your computer's I folder, which is usually F in UNIX. If it doesn't, or if you wish to store this application's session files in a different place, you may pass the third argument like so: + + $session = new CGI::Session(undef, undef, {Directory=>'../tmp/sessions'}); + +Now it will store all the newly created sessions in (and will attempt to initialize requested sessions from) that folder. Don't worry if the directory hierarchy you want to use doesn't already exist. It will be created for you. For details on how session data are stored refer to L, which is the default driver used in our above example. + +There is one small, but very important thing your application needs to perform after creating CGI::Session object as above. It needs to drop Session ID as an I into the user's computer. CGI::Session will use this cookie to identify the user at his/her next request and will be able to load his/her previously stored session data. + +To make sure CGI::Session will be able to read your cookie at next request you need to consult its C method for cookie's suggested name: + + $cookie = $query->cookie( -name => $session->name, + -value => $session->id ); + print $query->header( -cookie=>$cookie ); + +C returns C by default. If you prefer a different cookie name, you can change it as easily too, but you have to do it before CGI::Session object is created: + + CGI::Session->name("SID"); + $session = new CGI::Session(); + +Baking the cookie wasn't too difficult, was it? But there is an even easier way to send a cookie using CGI::Session: + + print $session->header(); + +The above will create the cookie using L and will return proper http headers using L's L method. Any arguments to L will be passed to L. + +Of course, this method of initialization will only work if client is accepting cookies. If not you would have to pass session ID in each URL of your application as QUERY_STRING. For CGI::Session to detect it the name of the parameter should be the same as returned by L: + + printf ("click me", $session->name, $session->id); + +If you already have session id to be initialized you may pass it as the only argument, or the second argument of multi-argument syntax: + + $session = new CGI::Session( $sid ); + $session = new CGI::Session( "serializer:freezethaw", $sid ); + $session = new CGI::Session( "driver:mysql", $sid, {Handle=>$dbh} ); + +By default CGI::Session uses standard L to parse queries and cookies. If you prefer to use a different, but compatible object you can pass that object in place of $sid: + + $cgi = new CGI::Simple(); + $session = new CGI::Session ( $cgi ); + $session = new CGI::Session( "driver:db_file;serializer:storable", $cgi); + # etc + +See L + +=head2 STORING DATA + +L offers L, which behaves exactly as L with identical syntax. L is used for storing data in session as well as for accessing already stored data. + +Imagine your customer submitted a login form on your Web site. You, as a good host, wanted to remember the guest's name, so you can a) greet him accordingly when he visits your site again, or b) to be helpful by filling out I part of his login form, so the customer can jump right to the I field without having to type his username again. + + my $name = $cgi->param('username'); + $session->param('username', $name); + +Notice, we're grabbing I value of the field using CGI.pm's (or another compatible library's) C method, and storing it in session using L's L method. + +If you have too many stuff to transfer into session, you may find yourself typing the above code over and over again. I've done it, and believe me, it gets very boring too soon, and is also error-prone. So we introduced the following handy method: + + $session->save_param(['name']); + +If you wanted to store multiple form fields just include them all in the second list: + + $session->save_param(['name', 'email']); + +If you want to store all the available I parameters you can omit the arguments: + + $session->save_param(); + +See L for more details. + +When storing data in the session you're not limited to strings. You can store arrays, hashes and even most objects. You will need to pass them as references (except objects). + +For example, to get all the selected values of a scrolling list and store it in the session: + + my @fruits = $cgi->param('fruits'); + $session->param('fruits', \@fruits); + +For parameters with multiple values save_param() will do the right thing too. So the above is the same as: + + $session->save_param($cgi, ['fruits']); + +All the updates to the session data using above methods will not reflect in the data store until your application exits, or C<$session> goes out of scope. If, for some reason, you need to commit the changes to the data store before your application exits you need to call L method: + + $session->flush(); + +I've written a lot of code, and never felt need for using C method, since CGI::Session calls this method at the end of each request. There are, however, occasions I can think of one may need to call L. + +=head2 ACCESSING STORED DATA + +There's no point of storing data if you cannot access it. You can access stored session data by using the same L you once used to store them. Remember the Username field from the previous section that we stored in the session? Let's read it back so we can partially fill the Login form for the user: + + $name = $session->param("name"); + printf "", $name; + +To retrieve previously stored @fruits do not forget to de reference it: + + @fruits = @{ $session->param('fruits') }; + +Very frequently, you may find yourself having to create pre-filled and pre-selected forms, like radio buttons, checkboxes and drop down menus according to the user's preferences or previous action. With text and textareas it's not a big deal - you can simply retrieve a single parameter from the session and hard code the value into the text field. But how would you do it when you have a group of radio buttons, checkboxes and scrolling lists? For this purpose, CGI::Session provides L method, which loads given session parameters to a CGI object (assuming they have been previously saved with L or alternative): + + $session->load_param($cgi, ["fruits"]); + +Now when you say: + + print $cgi->checkbox_group(fruits=>['apple', 'banana', 'apricot']); + +See L for details. + +Generated checkboxes will be pre-filled using previously saved information. To see example of a real session-powered application consider http://handalak.com/cgi-bin/subscriptions.cgi + +If you're making use of L to separate the code from the skin, you can as well associate L object with HTML::Template and access all the parameters from within HTML files. We love this trick! + + $template = new HTML::Template(filename=>"some.tmpl", associate=>$session); + print $template->output(); + +Assuming the session object stored "first_name" and "email" parameters while being associated with HTML::Template, you can access those values from within your "some.tmpl" file now: + + Hello ! + +See L for details. + +=head2 CLEARING SESSION DATA + +You store session data, you access session data and at some point you will want to clear certain session data, if not all. For this purpose L provides L method which optionally takes one argument as an arrayref indicating which session parameters should be deleted from the session object: + + $session->clear(["~logged-in", "email"]); + +Above line deletes "~logged-in" and "email" session parameters from the session. And next time you say: + + $email = $session->param("email"); + +it returns undef. If you omit the argument to L, be warned that all the session parameters you ever stored in the session object will get deleted. Note that it does not delete the session itself. Session stays open and accessible. It's just the parameters you stored in it gets deleted + +See L for details. + +=head2 DELETING A SESSION + +If there's a start there's an end. If session could be created, it should be possible to delete it from the disk for good: + + $session->delete(); + +The above call to L deletes the session from the disk for good. Do not confuse it with L, which only clears certain session parameters but keeps the session open. + +See L for details. + +=head2 EXPIRATION + +L provides limited means to expire sessions. Expiring a session is the same as deleting it via delete(), but deletion takes place automatically. To expire a session, you need to tell the library how long the session would be valid after the last access time. When that time is met, CGI::Session refuses to retrieve the session. It deletes the session and returns a brand new one. To assign expiration ticker for a session, use L: + + $session->expire(3600); # expire after 3600 seconds + $session->expire('+1h'); # expire after 1 hour + $session->expire('+15m'); # expire after 15 minutes + $session->expire('+1M'); # expire after a month and so on. + +When session is set to expire at some time in the future, but session was not requested at or after that time has passed it will remain in the disk. When expired session is requested CGI::Session will remove the data from disk, and will initialize a brand new session. + +See L for details. + +Before CGI::Session 4.x there was no way of intercepting requests to expired sessions. CGI::Session 4.x introduced new kind of constructor, L, which is identical in use to L, but is not allowed to create sessions. It can only load them. If session is found to be expired, or session does not exist it will return an empty CGI::Session object. And if session is expired, in addition to being empty, its status will also be set to expired. You can check against these conditions using L and L methods. If session was loaded successfully object returned by C is as good a session as the one returned by C: + + $session = CGI::Session->load() or die CGI::Session->errstr; + if ( $session->is_expired ) { + die "Your session expired. Please refresh your browser to re-start your session"; + } + if ( $session->is_empty ) { + $session = $session->new(); + } + +Above example is worth an attention. Remember, all expired sessions are empty sessions, but not all empty sessions are expired sessions. Following this rule we have to check with C before checking with C. There is another thing about the above example. Notice how its creating new session when un existing session was requested? By calling C as an object method! Handy thing about that is, when you call C on a session object new object will be created using the same configuration as the previous object. + +For example: + + $session = CGI::Session->load("driver:mysql;serializer:storable", undef, {Handle=>$dbh}); + if ( $session->is_expired ) { + die "Your session is expired. Please refresh your browser to re-start your session"; + } + if ( $session->is_empty ) { + $session = $session->new(); + } + +Initial C<$session> object was configured with B as the driver, B as the serializer and B<$dbh> as the database handle. Calling C< new() > on this object will return an object of the same configuration. So C< $session > object returned from C< new() > in the above example will use B as the driver, B as the serializer and B<$dbh> as the database handle. + +See L, L, L for details. + +Sometimes it makes perfect sense to expire a certain session parameter, instead of the whole session. I usually do this in my login enabled sites, where after the user logs in successfully, I set his/her "_logged_in" session parameter to true, and assign an expiration ticker on that flag to something like 30 minutes. It means, after 30 idle minutes CGI::Session will L "_logged_in" flag, indicating the user should log in over again. I agree, the same effect can be achieved by simply expiring() the session itself, but by doing this we would loose other session parameters, such as user's shopping cart, session-preferences and the like. + +This feature can also be used to simulate layered authentication, such as, you can keep the user's access to his/her personal profile information for as long as 60 minutes after a successful login, but expire his/her access to his credit card information after 5 idle minutes. To achieve this effect, we will use L method again: + + $session->expire(_profile_access, '1h'); + $session->expire(_cc_access, '5m'); + +With the above syntax, the person will still have access to his personal information even after 5 idle hours. But when he tries to access or update his/her credit card information, he may be displayed a "login again, please" screen. + +See L for details. + +This concludes our discussion of CGI::Session programming style. The rest of the manual covers some L<"SECURITY"> issues. Driver specs from the previous manual were moved to L. + +=head1 SECURITY + +"How secure is using CGI::Session?", "Can others hack down people's sessions using another browser if they can get the session id of the user?", "Are the session ids easy to guess?" are the questions I find myself answering over and over again. + +=head2 STORAGE + +Security of the library does in many aspects depend on the implementation. After making use of this library, you no longer have to send all the information to the user's cookie except for the session id. But, you still have to store the data in the server side. So another set of questions arise, can an evil person get access to session data in your server, even if he does, can he make sense out of the data in the session file, and even if he can, can he reuse the information against a person who created that session. As you see, the answer depends on yourself who is implementing it. + +=over 4 + +=item * + +First rule of thumb, do not store users' passwords or other sensitive data in the session, please. If you have to, use one-way encryption, such as md5, or SHA-1-1. For my own experience I can assure you that in properly implemented session-powered Web applications there is never a need for it. + +=item * + +Default configuration of the driver makes use of L class to serialize data to make it possible to save it in the disk. Data::Dumper's result is a human readable data structure, which, if opened, can be interpreted easily. If you configure your session object to use either L or L as a serializer, this would make it more difficult for bad guys to make sense out of session data. But don't use this as the only precaution. Since evil fingers can type a quick program using L or L to decipher session files very easily. + +=item * + +Do not allow anyone to update contents of session files. If you're using L serialized data string needs to be eval()ed to bring the original data structure back to life. Of course, we use L to do it safely, but your cautiousness does no harm either. + +=item * + +Do not keep sessions open for very long. This will increase the possibility that some bad guy may have someone's valid session id at a given time (acquired somehow). To do this use L method to set expiration ticker. The more sensitive the information on your Web site is, the sooner the session should be set to expire. + +=back + +=head2 SESSION IDs + +Session ids are not easily guessed (unless you're using L)! Default configuration of CGI::Session uses L to generate random, 32 character long identifier. Although this string cannot be guessed as easily by others, if they find it out somehow, can they use this identifier against the other person? + +Consider the scenario, where you just give someone either via email or an instant messaging a link to a Web site where you're currently logged in. The URL you give to that person contains a session id as part of a query string. If the site was initializing the session solely using query string parameter, after clicking on that link that person now appears to that site as you, and might have access to all of your private data instantly. + +Even if you're solely using cookies as the session id transporters, it's not that difficult to plant a cookie in the cookie file with the same id and trick the web browser to send that particular session id to the server. So key for security is to check if the person who's asking us to retrieve a session data is indeed the person who initially created the session data. + +One way to help with this is by also checking that the IP address that the session is being used from is always same. However, this turns out not to be practical in common cases because some large ISPs (such as AOL) use proxies which cause each and every request from the same user to come from different IP address. + +If you have an application where you are sure your users' IPs are constant during a session, you can consider enabling an option to make this check: + + use CGI::Session ( '-ip_match' ); + +For backwards compatibility, you can also achieve this by setting $CGI::Session::IP_MATCH to a true value. This makes sure that before initializing a previously stored session, it checks if the ip address stored in the session matches the ip address of the user asking for that session. In which case the library returns the session, otherwise it dies with a proper error message. + +=head1 LICENSING + +For support and licensing see L + +=cut diff --git a/qooxdoo/source/perl/JSON.pm b/qooxdoo/source/perl/JSON.pm new file mode 100755 index 0000000..59686e0 --- /dev/null +++ b/qooxdoo/source/perl/JSON.pm @@ -0,0 +1,725 @@ +package JSON; + +use strict; +use base qw(Exporter); + +@JSON::EXPORT = qw(objToJson jsonToObj); + +use vars qw($AUTOCONVERT $VERSION $UnMapping $BareKey $QuotApos + $ExecCoderef $SkipInvalid $Pretty $Indent $Delimiter + $KeySort $ConvBlessed $SelfConvert $UTF8 $SingleQuote); + +$VERSION = '1.14'; + +$AUTOCONVERT = 1; +$SkipInvalid = 0; +$ExecCoderef = 0; +$Pretty = 0; # pretty-print mode switch +$Indent = 2; # (for pretty-print) +$Delimiter = 2; # (for pretty-print) 0 => ':', 1 => ': ', 2 => ' : ' +$UnMapping = 0; # +$BareKey = 0; # +$QuotApos = 0; # +$KeySort = undef; # Code-ref to provide sort ordering in converter +$UTF8 = 0; +$SingleQuote = 0; + +my $USE_UTF8; + +BEGIN { + $USE_UTF8 = $] >= 5.008 ? 1 : 0; + sub USE_UTF8 { $USE_UTF8; } +} + +use JSON::Parser; +use JSON::Converter; + +my $parser; # JSON => Perl +my $conv; # Perl => JSON + + +############################################################################## +# CONSTRCUTOR - JSON objects delegate all processes +# to JSON::Converter and JSON::Parser. +############################################################################## + +sub new { + my $class = shift; + my %opt = @_; + bless { + conv => undef, # JSON::Converter [perl => json] + parser => undef, # JSON::Parser [json => perl] + # below fields are for JSON::Converter + autoconv => $AUTOCONVERT, + skipinvalid => $SkipInvalid, + execcoderef => $ExecCoderef, + pretty => $Pretty , + indent => $Indent , + delimiter => $Delimiter , + keysort => $KeySort , + convblessed => $ConvBlessed, + selfconvert => $SelfConvert, + singlequote => $SingleQuote, + # below fields are for JSON::Parser + unmapping => $UnMapping, + quotapos => $QuotApos , + barekey => $BareKey , + # common options + utf8 => $UTF8 , + # overwrite + %opt, + }, $class; +} + + +############################################################################## +# METHODS +############################################################################## + +*parse_json = \&jsonToObj; + +*to_json = \&objToJson; + +sub jsonToObj { + my $self = shift; + my $js = shift; + + if(!ref($self)){ # class method + my $opt = __PACKAGE__->_getParamsForParser($js); + $js = $self; + $parser ||= new JSON::Parser; + $parser->jsonToObj($js, $opt); + } + else{ # instance method + my $opt = $self->_getParamsForParser($_[0]); + $self->{parser} ||= ($parser ||= JSON::Parser->new); + $self->{parser}->jsonToObj($js, $opt); + } +} + + +sub objToJson { + my $self = shift || return; + my $obj = shift; + + if(ref($self) !~ /JSON/){ # class method + my $opt = __PACKAGE__->_getParamsForConverter($obj); + $obj = $self; + $conv ||= JSON::Converter->new(); + $conv->objToJson($obj, $opt); + } + else{ # instance method + my $opt = $self->_getParamsForConverter($_[0]); + $self->{conv} + ||= JSON::Converter->new( %$opt ); + $self->{conv}->objToJson($obj, $opt); + } +} + + +####################### + + +sub _getParamsForParser { + my ($self, $opt) = @_; + my $params; + + if(ref($self)){ # instance + my @names = qw(unmapping quotapos barekey utf8); + my ($unmapping, $quotapos, $barekey, $utf8) = @{$self}{ @names }; + $params = { + unmapping => $unmapping, quotapos => $quotapos, + barekey => $barekey, utf8 => $utf8, + }; + } + else{ # class + $params = { + unmapping => $UnMapping, barekey => $BareKey, + quotapos => $QuotApos, utf8 => $UTF8, + }; + } + + if($opt and ref($opt) eq 'HASH'){ + for my $key ( keys %$opt ){ + $params->{$key} = $opt->{$key}; + } + } + + return $params; +} + + +sub _getParamsForConverter { + my ($self, $opt) = @_; + my $params; + + if(ref($self)){ # instance + my @names + = qw(pretty indent delimiter autoconv keysort convblessed selfconvert utf8 singlequote); + my ($pretty, $indent, $delimiter, $autoconv, + $keysort, $convblessed, $selfconvert, $utf8, $singlequote) + = @{$self}{ @names }; + $params = { + pretty => $pretty, indent => $indent, + delimiter => $delimiter, autoconv => $autoconv, + keysort => $keysort, convblessed => $convblessed, + selfconvert => $selfconvert, utf8 => $utf8, + singlequote => $singlequote, + }; + } + else{ # class + $params = { + pretty => $Pretty, indent => $Indent, + delimiter => $Delimiter, autoconv => $AUTOCONVERT, + keysort => $KeySort, convblessed => $ConvBlessed, + selfconvert => $SelfConvert, utf8 => $UTF8, + singlequote => $SingleQuote, + }; + } + + if($opt and ref($opt) eq 'HASH'){ + for my $key ( keys %$opt ){ + $params->{$key} = $opt->{$key}; + } + } + + return $params; +} + +############################################################################## +# ACCESSOR +############################################################################## +BEGIN{ + for my $name (qw/autoconv pretty indent delimiter + unmapping keysort convblessed selfconvert singlequote/) + { + eval qq{ + sub $name { \$_[0]->{$name} = \$_[1] if(defined \$_[1]); \$_[0]->{$name} } + }; + } +} + +############################################################################## +# NON STRING DATA +############################################################################## + +# See JSON::Parser for JSON::NotString. + +sub Number { + my $num = shift; + + return undef if(!defined $num); + + if( $num =~ /^-?(?:\d+)(?:\.\d*)?(?:[eE][-+]?\d+)?$/ + or $num =~ /^0[xX](?:[0-9a-zA-Z])+$/ ) + { + return bless {value => $num}, 'JSON::NotString'; + } + else{ + return undef; + } +} + +sub True { + bless {value => 'true'}, 'JSON::NotString'; +} + +sub False { + bless {value => 'false'}, 'JSON::NotString'; +} + +sub Null { + bless {value => undef}, 'JSON::NotString'; +} + +############################################################################## +1; +__END__ + +=pod + +=head1 NAME + +JSON - parse and convert to JSON (JavaScript Object Notation). + +=head1 SYNOPSIS + + use JSON; + + $obj = { + id => ["foo", "bar", { aa => 'bb'}], + hoge => 'boge' + }; + + $js = objToJson($obj); + # this is {"id":["foo","bar",{"aa":"bb"}],"hoge":"boge"}. + $obj = jsonToObj($js); + # the data structure was restored. + + # OOP + + my $json = new JSON; + + $obj = {id => 'foo', method => 'echo', params => ['a','b']}; + $js = $json->objToJson($obj); + $obj = $json->jsonToObj($js); + + # pretty-printing + $js = $json->objToJson($obj, {pretty => 1, indent => 2}); + + $json = JSON->new(pretty => 1, delimiter => 0); + $json->objToJson($obj); + + +=head1 TRANSITION PLAN + +In the next large update version, JSON and JSONRPC modules are split. + + JSON::Parser and JSON::Converter are deleted from JSON dist. + JSON and JSON::PP in JSON dist. + + JSON becomes wrapper to JSON::XS and/or JSON::PP. + + JSONRPC* and Apache::JSONRPC are deleted from JSON dist. + JSONRPC::Client, JSONRPC::Server and JSONRPC::Procedure in JSON::RPC dist. + + Modules in JSON::RPC dist supports JSONRPC protocol v1.1 and 1.0. + + +=head1 DESCRIPTION + +This module converts between JSON (JavaScript Object Notation) and Perl +data structure into each other. +For JSON, See to http://www.crockford.com/JSON/. + + +=head1 METHODS + +=over 4 + +=item new() + +=item new( %options ) + +returns a JSON object. The object delegates the converting and parsing process +to L and L. + + my $json = new JSON; + +C can take some options. + + my $json = new JSON (autoconv => 0, pretty => 1); + +Following options are supported: + +=over 4 + +=item autoconv + +See L for more info. + +=item skipinvalid + +C does C when it encounters any invalid data +(for instance, coderefs). If C is set with true, +the function convets these invalid data into JSON format's C. + +=item execcoderef + +C does C when it encounters any code reference. +However, if C is set with true, executes the coderef +and uses returned value. + +=item pretty + +See L for more info. + +=item indent + +See L for more info. + +=item delimiter + +See L for more info. + +=item keysort + +See L for more info. + +=item convblessed + +See L for more info. + +=item selfconvert + +See L for more info. + +=item singlequote + +See L for more info. + +=back + + +=item objToJson( $object ) + +=item objToJson( $object, $hashref ) + +takes perl data structure (basically, they are scalars, arrayrefs and hashrefs) +and returns JSON formated string. + + my $obj = [1, 2, {foo => bar}]; + my $js = $json->objToJson($obj); + # [1,2,{"foo":"bar"}] + +By default, returned string is one-line. However, you can get pretty-printed +data with C option. Please see below L. + + my $js = $json->objToJson($obj, {pretty => 1, indent => 2}); + # [ + # 1, + # 2, + # { + # "foo" : "bar" + # } + # ] + +=item jsonToObj( $js ) + +takes a JSON formated data and returns a perl data structure. + + +=item autoconv() + +=item autoconv($bool) + +This is an accessor to C. See L for more info. + +=item pretty() + +=item pretty($bool) + +This is an accessor to C. It takes true or false. +When prrety is true, C returns prrety-printed string. +See L for more info. + +=item indent() + +=item indent($integer) + +This is an accessor to C. +See L for more info. + +=item delimiter() + +This is an accessor to C. +See L for more info. + +=item unmapping() + +=item unmapping($bool) + +This is an accessor to C. +See L for more info. + +=item keysort() + +=item keysort($coderef) + +This is an accessor to C. +See L for more info. + +=item convblessed() + +=item convblessed($bool) + +This is an accessor to C. +See L for more info. + +=item selfconvert() + +=item selfconvert($bool) + +This is an accessor to C. +See L for more info. + +=item singlequote() + +=item singlequote($bool) + +This is an accessor to C. +See L for more info. + + +=back + +=head1 MAPPING + + (JSON) {"param" : []} + ( => Perl) {'param' => []}; + + (JSON) {"param" : {}} + ( => Perl) {'param' => {}}; + + (JSON) {"param" : "string"} + ( => Perl) {'param' => 'string'}; + + JSON {"param" : null} + => Perl {'param' => bless( {'value' => undef}, 'JSON::NotString' )}; + or {'param' => undef} + + (JSON) {"param" : true} + ( => Perl) {'param' => bless( {'value' => 'true'}, 'JSON::NotString' )}; + or {'param' => 1} + + (JSON) {"param" : false} + ( => Perl) {'param' => bless( {'value' => 'false'}, 'JSON::NotString' )}; + or {'param' => 2} + + (JSON) {"param" : 0xff} + ( => Perl) {'param' => 255}; + + (JSON) {"param" : 010} + ( => Perl) {'param' => 8}; + +These JSON::NotString objects are overloaded so you don't care about. +Since 1.00, L is added. When that option is set, +{"param" : null} will be converted into {'param' => undef}, insted of +{'param' => bless( {'value' => undef}, 'JSON::NotString' )}. + + +Perl's C is converted to 'null'. + + +=head1 PRETTY PRINTING + +If you'd like your JSON output to be pretty-printed, pass the C +parameter to objToJson(). You can affect the indentation (which defaults to 2) +by passing the C parameter to objToJson(). + + my $str = $json->objToJson($obj, {pretty => 1, indent => 4}); + +In addition, you can set some number to C option. +The available numbers are only 0, 1 and 2. +In pretty-printing mode, when C is 1, one space is added +after ':' in object keys. If C is 2, it is ' : ' and +0 is ':' (default is 2). If you give 3 or more to it, the value +is taken as 2. + + +=head1 AUTOCONVERT + +By default, $JSON::AUTOCONVERT is true. + + (Perl) {num => 10.02} + ( => JSON) {"num" : 10.02} + +it is not C<{"num" : "10.02"}>. + +But set false value with $JSON::AUTOCONVERT: + + (Perl) {num => 10.02} + ( => JSON) {"num" : "10.02"} + +it is not C<{"num" : 10.02}>. + +You can explicitly sepcify: + + $obj = { + id => JSON::Number(10.02), + bool1 => JSON::True, + bool2 => JSON::False, + noval => JSON::Null, + }; + + $json->objToJson($obj); + # {"noval" : null, "bool2" : false, "bool1" : true, "id" : 10.02} + +C returns C when an argument invalid format. + +=head1 UNMAPPING OPTION + +By default, $JSON::UnMapping is false and JSON::Parser converts +C, C, C into C objects. +You can set true into $JSON::UnMapping to stop the mapping function. +In that case, JSON::Parser will convert C, C, C +into C, 1, 0. + +=head1 BARE KEY OPTION + +You can set a true value into $JSON::BareKey for JSON::Parser to parse +bare keys of objects. + + local $JSON::BareKey = 1; + $obj = jsonToObj('{foo:"bar"}'); + +=head1 SINGLE QUOTATION OPTION + +You can set a true value into $JSON::QuotApos for JSON::Parser to parse +any keys and values quoted by single quotations. + + local $JSON::QuotApos = 1; + $obj = jsonToObj(q|{"foo":'bar'}|); + $obj = jsonToObj(q|{'foo':'bar'}|); + +With $JSON::BareKey: + + local $JSON::BareKey = 1; + local $JSON::QuotApos = 1; + $obj = jsonToObj(q|{foo:'bar'}|); + +=head1 HASH KEY SORT ORDER + +By default objToJSON will serialize hashes with their keys in random +order. To control the ordering of hash keys, you can provide a standard +'sort' function that will be used to control how hashes are converted. + +You can provide either a fully qualified function name or a CODEREF to +$JSON::KeySort or $obj->keysort. + +If you give any integers (excluded 0), the sort function will work as: + + sub { $a cmp $b } + +Note that since the sort function is external to the JSON module the +magical $a and $b arguments will not be in the same package. In order +to gain access to the sorting arguments, you must either: + + o use the ($$) prototype (slow) + o Fully qualify $a and $b from the JSON::Converter namespace + +See the documentation on sort for more information. + + local $JSON::KeySort = 'My::Package::sort_function'; + + or + + local $JSON::KeySort = \&_some_function; + + sub sort_function { + $JSON::Converter::a cmp $JSON::Converter::b; + } + + or + + sub sort_function ($$) { + my ($a, $b) = @_; + + $a cmp $b + } + +=head1 BLESSED OBJECT + +By default, JSON::Converter doesn't deal with any blessed object +(returns C or C in the JSON format). +If you use $JSON::ConvBlessed or C option, +the module can convert most blessed object (hashref or arrayref). + + local $JSON::ConvBlessed = 1; + print objToJson($blessed); + +This option slows down the converting speed. + +If you use $JSON::SelfConvert or C option, +the module will test for a C method on the object, +and will rely on this method to obtain the converted value of +the object. + +=head1 UTF8 + +You can set a true value into $JSON::UTF8 for JSON::Parser +and JSON::Converter to set UTF8 flag into strings contain utf8. + + +=head1 CONVERT WITH SINGLE QUOTES + +You can set a true value into $JSON::SingleQuote for JSON::Converter +to quote any keys and values with single quotations. + +You want to parse single quoted JSON data, See L. + + +=head1 EXPORT + +C, C. + +=head1 TODO + +Which name is more desirable? JSONRPC or JSON::RPC. + +SingleQuote and QuotApos... + + +=head1 SEE ALSO + +L, L, L + +If you want the speed and the saving of memory usage, +check L. + +=head1 ACKNOWLEDGEMENTS + +I owe most JSONRPC idea to L and L. + +SHIMADA pointed out many problems to me. + +Mike Castle Edalgoda[at]ix.netcom.comE suggested +better packaging way. + +Jeremy Muhlich Ejmuhlich[at]bitflood.orgE help me +escaped character handling in JSON::Parser. + +Adam Sussman Eadam.sussman[at]ticketmaster.comE +suggested the octal and hexadecimal formats as number. +Sussman also sent the 'key sort' and 'hex number autoconv' patch +and 'HASH KEY SORT ORDER' section. + +Tatsuhiko Miyagawa Emiyagawa[at]bulknews.netE +taught a terrible typo and gave some suggestions. + +David Wheeler Edavid[at]kineticode.comE +suggested me supporting pretty-printing and +gave a part of L. + +Rusty Phillips Erphillips[at]edats.comE +suggested me supporting the query object other than CGI.pm +for JSONRPC::Transport::HTTP::CGI. + +Felipe Gasper Egasperfm[at]uc.eduE +pointed to a problem of JSON::NotString with undef. +And show me patches for 'bare key option' & 'single quotation option'. + +Yaman Saqqa Eabulyomon[at]gmail.comE +helped my decision to support the bare key option. + +Alden DoRosario Eadorosario[at]chitika.comE +tought JSON::Conveter::_stringfy (<= 0.992) is very slow. + +Brad Baxter sent to 'key sort' patch and thought a bug in JSON. + +Jacob and Jay Buffington sent 'blessed object conversion' patch. + +Thanks to Peter Edwards, IVAN, and all testers for bug reports. + +Yann Kerherve sent 'selfconverter' patch(code, document and test). + +Annocpan users comment on JSON pod. See http://annocpan.org/pod/JSON + +And Thanks very much to JSON by JSON.org (Douglas Crockford) and +JSON-RPC by http://json-rpc.org/ + + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2005-2007 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + + diff --git a/qooxdoo/source/perl/JSON/Converter.pm b/qooxdoo/source/perl/JSON/Converter.pm new file mode 100755 index 0000000..1bcc398 --- /dev/null +++ b/qooxdoo/source/perl/JSON/Converter.pm @@ -0,0 +1,473 @@ +package JSON::Converter; +############################################################################## + +use Carp; + +use vars qw($VERSION $USE_UTF8); +use strict; +use JSON (); +use B (); + + +$VERSION = '1.13'; + +BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *JSON::Converter::blessed = \&Scalar::Util::blessed; + } + else{ # This code is from Sclar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *JSON::Converter::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + } + + if ($] < 5.006) { + eval q{ + sub B::SVf_IOK () { 0x00010000; } + sub B::SVf_NOK () { 0x00020000; } + }; + } + + $USE_UTF8 = JSON->USE_UTF8; + +} + + +############################################################################## + +sub new { + my $class = shift; + bless {indent => 2, pretty => 0, delimiter => 2, @_}, $class; +} + + +sub objToJson { + my $self = shift; + my $obj = shift; + my $opt = shift; + + local(@{$self}{qw/autoconv execcoderef skipinvalid/}); + local(@{$self}{qw/pretty indent delimiter keysort convblessed utf8 singlequote/}); + + $self->_initConvert($opt); + + if($self->{convblessed}){ + $obj = _blessedToNormalObject($obj); + } + + #(not hash for speed) + local @JSON::Converter::obj_addr; # check circular references + # for speed + local $JSON::Converter::pretty = $self->{pretty}; + local $JSON::Converter::keysort = !$self->{keysort} ? undef + : ref($self->{keysort}) eq 'CODE' ? $self->{keysort} + : $self->{keysort} =~ /\D+/ ? $self->{keysort} + : sub { $a cmp $b }; + local $JSON::Converter::autoconv = $self->{autoconv}; + local $JSON::Converter::execcoderef = $self->{execcoderef}; + local $JSON::Converter::selfconvert = $self->{selfconvert}; + local $JSON::Converter::utf8 = $self->{utf8}; + + local *_stringfy = *_stringfy_single_quote if($self->{singlequote}); + + return $self->_toJson($obj); +} + + +*hashToJson = \&objToJson; +*arrayToJson = \&objToJson; +*valueToJson = \&_valueToJson; + + +sub _toJson { + my ($self, $obj) = @_; + + if(ref($obj) eq 'HASH'){ + return $self->_hashToJson($obj); + } + elsif(ref($obj) eq 'ARRAY'){ + return $self->_arrayToJson($obj); + } + elsif( $JSON::Converter::selfconvert + and blessed($obj) and $obj->can('toJson') ){ + return $self->_selfToJson($obj); + } + else{ + return; + } +} + + +sub _hashToJson { + my ($self, $obj) = @_; + my ($k,$v); + my %res; + + if (my $class = tied %$obj) { # by ddascalescu+perl [at] gmail.com + $class =~ s/=.*//; + tie %res, $class; + } + + my ($pre,$post) = $self->_upIndent() if($JSON::Converter::pretty); + + if (grep { $_ == $obj } @JSON::Converter::obj_addr) { + die "circle ref!"; + } + + push @JSON::Converter::obj_addr,$obj; + + for my $k (keys %$obj) { + my $v = $obj->{$k}; + $res{$k} = $self->_toJson($v) || $self->_valueToJson($v); + } + + pop @JSON::Converter::obj_addr; + + if ($JSON::Converter::pretty) { + $self->_downIndent(); + my $del = $self->{_delstr}; + return "{$pre" + . join(",$pre", map { _stringfy($_) . $del .$res{$_} } + (defined $JSON::Converter::keysort ? ( sort $JSON::Converter::keysort (keys %res)) : (keys %res) ) + ). "$post}"; + } + else{ + return '{'. join(',',map { _stringfy($_) .':' .$res{$_} } + (defined $JSON::Converter::keysort ? + ( sort $JSON::Converter::keysort (keys %res)) : (keys %res) ) + ) .'}'; + } + +} + + +sub _arrayToJson { + my ($self, $obj) = @_; + my @res; + + if (my $class = tied @$obj) { + $class =~ s/=.*//; + tie @res, $class; + } + + my ($pre,$post) = $self->_upIndent() if($JSON::Converter::pretty); + + if(grep { $_ == $obj } @JSON::Converter::obj_addr){ + die "circle ref!"; + } + + push @JSON::Converter::obj_addr,$obj; + + for my $v (@$obj){ + push @res, $self->_toJson($v) || $self->_valueToJson($v); + } + + pop @JSON::Converter::obj_addr; + + if ($JSON::Converter::pretty) { + $self->_downIndent(); + return "[$pre" . join(",$pre" ,@res) . "$post]"; + } + else { + return '[' . join(',' ,@res) . ']'; + } +} + + +sub _selfToJson { + my ($self, $obj) = @_; + if(grep { $_ == $obj } @JSON::Converter::obj_addr){ + die "circle ref!"; + } + push @JSON::Converter::obj_addr, $obj; + return $obj->toJson($self); +} + + +sub _valueToJson { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + if(!ref($value)){ + if($JSON::Converter::autoconv){ + return $value if($value =~ /^-?(?:0|[1-9][\d]*)(?:\.\d*)?(?:[eE][-+]?\d+)?$/); + return $value if($value =~ /^0[xX](?:[0-9a-fA-F])+$/); + return 'true' if($value =~ /^[Tt][Rr][Uu][Ee]$/); + return 'false' if($value =~ /^[Ff][Aa][Ll][Ss][Ee]$/); + } + + my $b_obj = B::svref_2object(\$value); # for round trip problem + # SvTYPE is IV or NV? + return $value # as is + if ($b_obj->FLAGS & B::SVf_IOK or $b_obj->FLAGS & B::SVf_NOK); + + return _stringfy($value); + } + elsif($JSON::Converter::execcoderef and ref($value) eq 'CODE'){ + my $ret = $value->(); + return 'null' if(!defined $ret); + return $self->_toJson($ret) || _stringfy($ret); + } + elsif( blessed($value) and $value->isa('JSON::NotString') ){ + return defined $value->{value} ? $value->{value} : 'null'; + } + else { + die "Invalid value" unless($self->{skipinvalid}); + return 'null'; + } + +} + + +my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', +# "/" => '\\/', # TODO +); + + +sub _stringfy { + my ($arg) = @_; + $arg =~ s/([\\"\n\r\t\f\b])/$esc{$1}/eg; + + unless (JSON->USE_UTF8) { + $arg =~ s/([\x00-\x07\x0b\x0e-\x1f])/'\\u00' . unpack('H2',$1)/eg; + return '"' . $arg . '"'; + } + + # suggestion from rt#25727 + $arg = join('', + map { + chr($_) =~ /[\x00-\x07\x0b\x0e-\x1f]/ ? + sprintf('\u%04x', $_) : + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%04x', $_) + } unpack('U*', $arg) + ); + + $JSON::Converter::utf8 and utf8::decode($arg); + + return '"' . $arg . '"'; +} + + +sub _stringfy_single_quote { + my $arg = shift; + $arg =~ s/([\\\n'\r\t\f\b])/$esc{$1}/eg; + + unless (JSON->USE_UTF8) { + $arg =~ s/([\x00-\x07\x0b\x0e-\x1f])/'\\u00' . unpack('H2',$1)/eg; + return "'" . $arg ."'"; + } + + $arg = join('', + map { + chr($_) =~ /[\x00-\x07\x0b\x0e-\x1f]/ ? + sprintf('\u%04x', $_) : + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%04x', $_) + } unpack('U*', $arg) + ); + + $JSON::Converter::utf8 and utf8::decode($arg); + + return "'" . $arg ."'"; +}; + + +############################################################################## + +sub _initConvert { + my $self = shift; + my %opt = %{ $_[0] } if(@_ > 0 and ref($_[0]) eq 'HASH'); + + $self->{autoconv} = $JSON::AUTOCONVERT if(!defined $self->{autoconv}); + $self->{execcoderef} = $JSON::ExecCoderef if(!defined $self->{execcoderef}); + $self->{skipinvalid} = $JSON::SkipInvalid if(!defined $self->{skipinvalid}); + + $self->{pretty} = $JSON::Pretty if(!defined $self->{pretty}); + $self->{indent} = $JSON::Indent if(!defined $self->{indent}); + $self->{delimiter} = $JSON::Delimiter if(!defined $self->{delimiter}); + $self->{keysort} = $JSON::KeySort if(!defined $self->{keysort}); + $self->{convblessed} = $JSON::ConvBlessed if(!defined $self->{convblessed}); + $self->{selfconvert} = $JSON::SelfConvert if(!defined $self->{selfconvert}); + $self->{utf8} = $JSON::UTF8 if(!defined $self->{utf8}); + $self->{singlequote} = $JSON::SingleQuote if(!defined $self->{singlequote}); + + for my $name (qw/autoconv execcoderef skipinvalid pretty + indent delimiter keysort convblessed selfconvert utf8 singlequote/){ + $self->{$name} = $opt{$name} if(defined $opt{$name}); + } + + if($self->{utf8} and !$USE_UTF8){ + $self->{utf8} = 0; warn "JSON::Converter couldn't use utf8."; + } + + $self->{indent_count} = 0; + + $self->{_delstr} = + $self->{delimiter} ? ($self->{delimiter} == 1 ? ': ' : ' : ') : ':'; + + $self; +} + + +sub _upIndent { + my $self = shift; + my $space = ' ' x $self->{indent}; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $self->{indent_count}; + + $self->{indent_count}++; + + $pre = "\n" . $space x $self->{indent_count}; + + return ($pre,$post); +} + + +sub _downIndent { $_[0]->{indent_count}--; } + + +# +# converting the blessed object to the normal object +# + +sub _blessedToNormalObject { require overload; + my ($obj) = @_; + + local @JSON::Converter::_blessedToNormal::obj_addr; + + return _blessedToNormal($obj); +} + + +sub _getObjType { + return '' if(!ref($_[0])); + ref($_[0]) eq 'HASH' ? 'HASH' : + ref($_[0]) eq 'ARRAY' ? 'ARRAY' : + $_[0]->isa('JSON::NotString') ? '' : + (overload::StrVal($_[0]) =~ /=(\w+)/)[0]; +} + + +sub _blessedToNormal { + my $type = _getObjType($_[0]); + return $type eq 'HASH' ? _blessedToNormalHash($_[0]) : + $type eq 'ARRAY' ? _blessedToNormalArray($_[0]) : + $type eq 'SCALAR' ? _blessedToNormalScalar($_[0]) : $_[0]; +} + + +sub _blessedToNormalHash { + my ($obj) = @_; + my %res; + + die "circle ref!" if(grep { overload::AddrRef($_) eq overload::AddrRef($obj) } + @JSON::Converter::_blessedToNormal::obj_addr); + + push @JSON::Converter::_blessedToNormal::obj_addr, $obj; + + for my $k (keys %$obj){ + $res{$k} = _blessedToNormal($obj->{$k}); + } + + pop @JSON::Converter::_blessedToNormal::obj_addr; + + return \%res; +} + + +sub _blessedToNormalArray { + my ($obj) = @_; + my @res; + + die "circle ref!" if(grep { overload::AddrRef($_) eq overload::AddrRef($obj) } + @JSON::Converter::_blessedToNormal::obj_addr); + + push @JSON::Converter::_blessedToNormal::obj_addr, $obj; + + for my $v (@$obj){ + push @res, _blessedToNormal($v); + } + + pop @JSON::Converter::_blessedToNormal::obj_addr; + + return \@res; +} + + +sub _blessedToNormalScalar { + my ($obj) = @_; + my $res; + + die "circle ref!" if(grep { overload::AddrRef($_) eq overload::AddrRef($obj) } + @JSON::Converter::_blessedToNormal::obj_addr); + + push @JSON::Converter::_blessedToNormal::obj_addr, $obj; + + $res = _blessedToNormal($$obj); + + pop @JSON::Converter::_blessedToNormal::obj_addr; + + return $res; # JSON can't really do scalar refs so it can't be \$res +} + +############################################################################## +1; +__END__ + + +=head1 METHODs + +=over + +=item objToJson + +convert a passed perl data structure into JSON object. +can't parse bleesed object by default. + +=item hashToJson + +convert a passed hash into JSON object. + +=item arrayToJson + +convert a passed array into JSON array. + +=item valueToJson + +convert a passed data into a string of JSON. + +=back + +=head1 COPYRIGHT + +makamaka [at] donzoko.net + +This library is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L, +L + +=cut diff --git a/qooxdoo/source/perl/JSON/PP.pm b/qooxdoo/source/perl/JSON/PP.pm new file mode 100755 index 0000000..dc2d39a --- /dev/null +++ b/qooxdoo/source/perl/JSON/PP.pm @@ -0,0 +1,1355 @@ +package JSON::PP; + +# JSON-2.0 + +use 5.005; +use strict; +use base qw(Exporter); +use overload; + +use Carp (); +use B (); +#use Devel::Peek; + +$JSON::PP::VERSION = '0.96'; + +@JSON::PP::EXPORT = qw(from_json to_json jsonToObj objToJson); + +*jsonToObj = *from_json; +*objToJson = *to_json; + + + +BEGIN { + my @properties = qw( + utf8 allow_nonref indent space_before space_after canonical max_depth shrink + allow_tied self_encode singlequote allow_bigint disable_UTF8 strict + allow_barekey escape_slash literal_value + ); + + # Perl version check, ascii() is enable? + # Helper module may set @JSON::PP::_properties. + if ($] >= 5.008) { + require Encode; + push @properties, 'ascii', 'latin1'; + + *utf8::is_utf8 = *Encode::is_utf8 if ($] == 5.008); + + *JSON_encode_ascii = *_encode_ascii; + *JSON_encode_latin1 = *_encode_latin1; + *JSON_decode_unicode = *_decode_unicode; + } + else { + my $helper = $] >= 5.006 ? 'JSON::PP56' : 'JSON::PP5005'; + eval qq| require $helper |; + if ($@) { Carp::croak $@; } + push @properties, @JSON::PP::_properties; + } + + for my $name (@properties) { + eval qq| + sub $name { + \$_[0]->{$name} = defined \$_[1] ? \$_[1] : 1; + \$_[0]; + } + |; + } + +} + + + +# Functions + +my %encode_allow_method + = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 allow_tied self_encode escape_slash/; +my %decode_allow_method + = map {($_ => 1)} qw/utf8 allow_nonref disable_UTF8 strict singlequote allow_bigint + allow_barekey literal_value/; + + +sub to_json { # encode + my ($obj, $opt) = @_; + + if ($opt) { + my $json = JSON::PP->new->utf8; + + for my $method (keys %$opt) { + Carp::croak("non acceptble option") + unless (exists $encode_allow_method{$method}); + $json->$method($opt->{$method}); + } + + return $json->encode($obj); + } + else { + return __PACKAGE__->new->utf8->encode($obj); + } + +} + + +sub from_json { # decode + my ($obj, $opt) = @_; + + if ($opt) { + my $json = JSON::PP->new->utf8; + + for my $method (keys %$opt) { + Carp::croak("non acceptble option") + unless (exists $decode_allow_method{$method}); + $json->$method($opt->{$method}); + } + + return $json->decode($obj); + } + else { + __PACKAGE__->new->utf8->decode(shift); + } +} + + +# Methods + +sub new { + my $class = shift; + my $self = { + max_depth => 32, + unmap => 1, + indent => 0, + fallback => sub { encode_error('Invalid value. JSON can only reference.') }, + }; + + bless $self, $class; +} + + +sub encode { + return $_[0]->encode_json($_[1]); +} + + +sub decode { + return $_[0]->decode_json($_[1], 0x00000000); +} + + +sub decode_prefix { + return $_[0]->decode_json($_[1], 0x00000001); +} + + +# accessor + +sub property { + my ($self, $name, $value) = @_; + + if (@_ == 1) { + Carp::croak('property() requires 1 or 2 arguments.'); + } + elsif (@_ == 2) { + $self->{$name}; + } + else { + $self->$name($value); + } +} + + +# pretty printing + +sub pretty { + my ($self, $v) = @_; + $self->{pretty} = defined $v ? $v : 1; + + if ($v) { # JSON::XS compati + $self->indent(3); + $self->space_before(1); + $self->space_after(1); + } + else { + $self->indent(0); + $self->space_before(0); + $self->space_after(0); + } + + $self; +} + +############################### + +sub JSON::true () { JSON::Literal::true->new; } + +sub JSON::false () { JSON::Literal::false->new; } + +sub JSON::null () { JSON::Literal::null->new; } + +############################### + +### +### Perl => JSON +### + +{ # Convert + + my $depth; + my $max_depth; + my $keysort; + my $indent; + my $indent_count; + my $ascii; + my $utf8; + my $self_encode; + my $disable_UTF8; + my $escape_slash; + + my $latin1; + + + sub encode_json { + my $self = shift; + my $obj = shift; + + $indent_count = 0; + $depth = 0; + + ($indent, $ascii, $utf8, $self_encode, $max_depth, $disable_UTF8, $escape_slash, $latin1) + = @{$self}{qw/indent ascii utf8 self_encode max_depth disable_UTF8 escape_slash latin1/}; + + $keysort = !$self->{canonical} ? undef + : ref($self->{canonical}) eq 'CODE' ? $self->{canonical} + : $self->{canonical} =~ /\D+/ ? $self->{canonical} + : sub { $a cmp $b }; + + my $str = $self->toJson($obj); + + if (!defined $str and $self->{allow_nonref}){ + $str = $self->valueToJson($obj); + } + + encode_error("non ref") unless(defined $str); + + return $str; + } + + + sub toJson { + my ($self, $obj) = @_; + my $type = ref($obj); + + if($type eq 'HASH'){ + return $self->hashToJson($obj); + } + elsif($type eq 'ARRAY'){ + return $self->arrayToJson($obj); + } + elsif ($type) { # blessed object? + if (blessed($obj)) { + if ($self->{self_encode} and $obj->can('toJson')) { + return $self->selfToJson($obj); + } + elsif (!$obj->isa('JSON::Literal')) { # handling in valueToJson + ($type) = B::svref_2object($obj) =~ /(.+)=/; + return $type eq 'B::AV' ? $self->arrayToJson($obj) + : $type eq 'B::HV' ? $self->hashToJson($obj) + : undef; + } + } + else { + return $self->valueToJson($obj); + } + } + else{ + return; + } + } + + + sub hashToJson { + my ($self, $obj) = @_; + my ($k,$v); + my %res; + + encode_error("data structure too deep (hit recursion limit)") + if (++$depth > $max_depth); + + $self->_tie_object($obj, \%res) if ($self->{allow_tied}); + + my ($pre, $post) = $indent ? $self->_upIndent() : ('', ''); + my $del = ($self->{space_before} ? ' ' : '') . ':' . ($self->{space_after} ? ' ' : ''); + + for my $k (keys %$obj) { + my $v = $obj->{$k}; + $res{$k} = $self->toJson($v) || $self->valueToJson($v); + } + + $self->_downIndent() if ($indent); + + return '{' . $pre + . join(",$pre", map { utf8::decode($_) if ($] < 5.008); + _stringfy($self, $_) + . $del . $res{$_} } _sort($self, \%res)) + . $post + . '}'; + } + + + sub arrayToJson { + my ($self, $obj) = @_; + my @res; + + encode_error("data structure too deep (hit recursion limit)") + if (++$depth > $max_depth); + + $self->_tie_object($obj, \@res) if ($self->{allow_tied}); + + my ($pre, $post) = $indent ? $self->_upIndent() : ('', ''); + + for my $v (@$obj){ + push @res, $self->toJson($v) || $self->valueToJson($v); + } + + $self->_downIndent() if ($indent); + + return '[' . $pre . join(",$pre" ,@res) . $post . ']'; + } + + + sub valueToJson { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + my $b_obj = B::svref_2object(\$value); # for round trip problem + # SvTYPE is IV or NV? + return $value # as is + if ($b_obj->FLAGS & B::SVf_IOK or $b_obj->FLAGS & B::SVf_NOK); + + my $type = ref($value); + + if(!$type){ + return _stringfy($self, $value); + } + elsif( blessed($value) and $value->isa('JSON::Literal') ){ + return $value->{str}; + } + elsif ($type) { + if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { + return $self->valueToJson("$value"); + } + + if ($type eq 'SCALAR' and defined $$value) { + return $$value eq '1' ? 'true' + : $$value eq '0' ? 'false' : encode_error("cannot encode reference."); + } + + if ($type eq 'CODE') { + encode_error("JSON can only reference."); + } + else { + encode_error("cannot encode reference."); + } + + } + else { + return $self->{fallback}->($value) + if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); + return 'null'; + } + + } + + + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + + + sub _stringfy { + my ($self, $arg) = @_; + + $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/eg; + $arg =~ s/\//\\\//g if ($escape_slash); + $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; + + if ($ascii) { + $arg = JSON_encode_ascii($arg); + } + + if ($latin1) { + $arg = JSON_encode_latin1($arg); + } + + if ($utf8 or $disable_UTF8) { + utf8::encode($arg); + } + + return '"' . $arg . '"'; + } + + + sub selfToJson { + my ($self, $obj) = @_; + return $obj->toJson($self); + } + + + sub encode_error { + my $error = shift; + Carp::croak "$error"; + } + + + sub _sort { + my ($self, $res) = @_; + defined $keysort ? (sort $keysort (keys %$res)) : keys %$res; + } + + + sub _tie_object { + my ($self, $obj, $res) = @_; + my $class; + # by ddascalescu+perl [at] gmail.com + if (ref($obj) eq 'ARRAY' and $class = tied @$obj) { + $class =~ s/=.*//; + tie @$res, $class; + } + elsif (ref($obj) eq 'HASH' and $class = tied %$obj) { + $class =~ s/=.*//; + tie %$res, $class; + } + } + + + sub _upIndent { + my $self = shift; + my $space = ' ' x $indent; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $indent_count; + + $indent_count++; + + $pre = "\n" . $space x $indent_count; + + return ($pre,$post); + } + + + sub _downIndent { $_[0]->{indent_count}--; } + +} # Convert + + + +sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : + join("", map { '\u' . $_ } + unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); + } unpack('U*', $_[0]) + ); +} + + +sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : + join("", map { '\u' . $_ } + unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); + } unpack('U*', $_[0]) + ); +} + + + +# +# JSON => Perl +# + +# from Adam Sussman +use Config; +my $max_intsize = length(((1 << (8 * $Config{intsize} - 2))-1)*2 + 1) - 1; +#my $max_intsize = length(2 ** ($Config{intsize} * 8)) - 1; + + +{ # PARSE + + my %escapes = ( # by Jeremy Muhlich + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", + '\\' => '\\', + ); + + my $text; # json data + my $at; # offset + my $ch; # 1chracter + my $len; # text length (changed according to UTF8 or NON UTF8) + + my $is_utf8; + my $depth; + my $encoding; + + my $literal_value; # unmmaping + my $utf8; # + my $max_depth; # max nest nubmer of objects and arrays + my $allow_bigint; # using Math::BigInt + my $disable_UTF8; # don't flag UTF8 on + my $singlequote; # loosely quoting + my $strict; # + my $allow_barekey; # bareKey + + # $opt flag + # 0x00000001 .... decode_prefix + + sub decode_json { + my ($self, $opt); # $opt is an effective flag during this decode_json. + + ($self, $text, $opt) = @_; + + ($at, $ch, $depth) = (0, '', 0); + + if (!defined $text or ref $text) { + decode_error("malformed text data."); + } + + $is_utf8 = 1 if (utf8::is_utf8($text)); + + $len = length $text; + + ($utf8, $literal_value, $max_depth, $allow_bigint, $disable_UTF8, $strict, $singlequote, $allow_barekey) + = @{$self}{qw/utf8 literal_value max_depth allow_bigint disable_UTF8 strict singlequote allow_barekey/}; + + unless ($self->{allow_nonref}) { + white(); + unless (defined $ch and ($ch eq '{' or $ch eq '[')) { + decode_error('JSON text must be an object or array' + . ' (but found number, string, true, false or null,' + . ' use allow_nonref to allow this)', 1); + } + } + + # Currently no effective + my @octets = unpack('C4', $text); + $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' + : (!$octets[0] and $octets[1]) ? 'UTF-16BE' + : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' + : ( $octets[2] ) ? 'UTF-16LE' + : (!$octets[2] ) ? 'UTF-32LE' + : 'unknown'; + + my $result = value(); + + if ($len > $at) { + my $consumed = $at - 1; + white(); + if ($ch) { + decode_error("garbage after JSON object") unless ($opt & 0x00000001); + return ($result, $consumed); + } + } + + $result; + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return string() if($ch eq '"' or ($singlequote and $ch eq "'")); + return number() if($ch eq '-'); + return $ch =~ /\d/ ? number() : word(); + } + + + sub string { + my ($i,$s,$t,$u); + my @utf16; + + $s = ''; # basically UTF8 flag on + + if($ch eq '"' or ($singlequote and $ch eq "'")){ + my $boundChar = $ch if ($singlequote); + + OUTER: while( defined(next_chr()) ){ + + if((!$singlequote and $ch eq '"') or ($singlequote and $ch eq $boundChar)){ + next_chr(); + + if (@utf16) { + decode_error("missing low surrogate character in surrogate pair"); + } + + if($disable_UTF8) { + utf8::encode($s) if (utf8::is_utf8($s)); + } + else { + utf8::decode($s); + } + + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ # UNICODE handling + my $u = ''; + + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[0-9a-fA-F]/); + $u .= $ch; + } + + $s .= JSON_decode_unicode($u, \@utf16) || next; + + } + else{ + $s .= $ch; + } + } + else{ + if ($utf8 and $is_utf8) { + if( hex(unpack('H*', $ch)) > 255 ) { + decode_error("malformed UTF-8 character in JSON string"); + } + } + elsif ($strict) { + if ($ch =~ /[\x00-\x1f\x22\x2f\x5c]/) { + decode_error('invalid character'); + } + } + + $s .= $ch; + } + } + } + + decode_error("Bad string (unexpected end)"); + } + + + sub white { + while( defined $ch ){ + if($ch le ' '){ + next_chr(); + } + elsif($ch eq '/'){ + next_chr(); + if($ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif($ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + decode_error("Unterminated comment"); + } + } + next; + } + else{ + decode_error("Syntax decode_error (whitespace)"); + } + } + else{ + last; + } + } + } + + + sub object { + my $o = {}; + my $k; + + if($ch eq '{'){ + decode_error('json structure too deep (hit recursion limit)', ) + if (++$depth > $max_depth); + next_chr(); + white(); + if(defined $ch and $ch eq '}'){ + next_chr(); + return $o; + } + while(defined $ch){ + $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if(!defined $ch or $ch ne ':'){ + decode_error("Bad object ; ':' expected"); + } + + next_chr(); + $o->{$k} = value(); + white(); + + last if (!defined $ch); + + if($ch eq '}'){ + next_chr(); + return $o; + } + elsif($ch ne ','){ + last; + } + next_chr(); + white(); + } + + decode_error("Bad object ; ,or } expected while parsing object/hash"); + } + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return $literal_value ? JSON::true : 1; + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return $literal_value ? JSON::null : undef; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return $literal_value ? JSON::false : 0; + } + } + + $at--; # for decode_error report + + decode_error("Syntax decode_error (word) 'null' expected") if ($word =~ /^n/); + decode_error("Syntax decode_error (word) 'true' expected") if ($word =~ /^t/); + decode_error("Syntax decode_error (word) 'false' expected") if ($word =~ /^f/); + decode_error("Syntax decode_error (word)" . + " malformed json string, neither array, object, number, string or atom"); + } + + + sub number { + my $n = ''; + my $v; + + # According to RFC4627, hex or oct digts are invalid. + if($ch eq '0'){ + my $peek = substr($text,$at,1); + my $hex = $peek =~ /[xX]/; # 0 or 1 + + if($hex){ + ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); + } + else{ # oct + ($n) = ( substr($text, $at) =~ /^([0-7]+)/); + } + + if(defined $n and length($n)){ + if (!$hex and length($n) == 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + $at += length($n) + $hex; + next_chr; + return $hex ? hex($n) : oct($n); + } + } + + if($ch eq '-'){ + $n = '-'; + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after initial minus)"); + } + } + + while(defined $ch and $ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if(defined $ch and $ch eq '.'){ + $n .= '.'; + + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after decimal point)"); + } + else { + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ + $n .= $ch; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-' or $ch =~ /\d/)){ + $n .= $ch; + } + else { + decode_error("malformed number (no digits after exp sign)"); + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + if ($allow_bigint) { # from Adam Sussman + require Math::BigInt; + return Math::BigInt->new($v) if ($v !~ /[.eE]/ and length $v > $max_intsize); + } + + return 0+$v; + } + + + sub array { + my $a = []; + + if ($ch eq '[') { + decode_error('json structure too deep (hit recursion limit)', 1) + if (++$depth > $max_depth); + next_chr(); + white(); + if(defined $ch and $ch eq ']'){ + next_chr(); + return $a; + } + + while(defined($ch)){ + push @$a, value(); + white(); + + if (!defined $ch) { + last; + } + + if($ch eq ']'){ + next_chr(); + return $a; + } + elsif($ch ne ','){ + last; + } + next_chr(); + white(); + } + } + + decode_error(", or ] expected while parsing array"); + } + + + sub decode_error { + my $error = shift; + my $no_rep = shift; + my $str = defined $text ? substr($text, $at) : ''; + + unless (length $str) { $str = '(end of string)'; } + + if ($no_rep) { + Carp::croak "$error"; + } + else { + Carp::croak "$error, at character offset $at ($str)"; + } + } + +} # PARSE + + +sub _decode_unicode { + my $u = $_[0]; + my $utf16 = $_[1]; + + # U+10000 - U+10FFFF + + # U+D800 - U+DBFF + if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? + push @$utf16, $u; + } + # U+DC00 - U+DFFF + elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? + unless (scalar(@$utf16)) { + decode_error("missing high surrogate character in surrogate pair"); + } + my $str = pack('H4H4', @$utf16, $u); + @$utf16 = (); + return Encode::decode('UTF-16BE', $str); # UTF-8 flag on + } + else { + if (scalar(@$utf16)) { + decode_error("surrogate pair expected"); + } + + return chr(hex($u)); + } + + return; +} + + +############################### +# Utilities +# + +BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *JSON::PP::blessed = \&Scalar::Util::blessed; + } + else{ # This code is from Sclar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *JSON::PP::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + } +} + + +############################### + +package JSON::Literal; +use overload ( + '""' => sub { $_[0]->{str} }, + 'bool' => sub { $_[0]->{value} }, + 'eq' => sub { $_[0]->{str} eq $_[1] }, + 'ne' => sub { $_[0]->{str} ne $_[1] }, +); + + +package JSON::Literal::true; +use base qw(JSON::Literal); + +use overload ( + '==' => sub { 1 == $_[1] }, + '!=' => sub { 1 != $_[1] }, +); + +sub new { bless { str => 'true', value => 1 }; } + + +package JSON::Literal::false; +use base qw(JSON::Literal); + +use overload ( + '==' => sub { 0 == $_[1] }, + '!=' => sub { 0 != $_[1] }, +); + +sub new { bless { str => 'false', value => 0 }; } + +package JSON::Literal::null; +use base qw(JSON::Literal); + +use overload ( + '==' => sub { -1 == $_[1] }, + '!=' => sub { -1 != $_[1] }, +); + +sub new { bless { str => 'null', value => undef }; } + +############################### + + +1; +__END__ +=pod + +=head1 NAME + +JSON::PP - An experimental JSON::XS compatible Pure Perl module. + +=head1 SYNOPSIS + + use JSON::PP; + + $obj = from_json($json_text); + $json_text = to_json($obj); + + # or + + $obj = jsonToObj($json_text); + $json_text = objToJson($obj); + + $json = new JSON; + $json_text = $json->ascii->pretty($obj); + + # you can set options to functions. + + $json_text = to_json($obj, {ascii => 1, intend => 2}); + $obj = from_json($json_text, {utf8 => 0}); + + +=head1 DESCRIPTION + +This module is L compatible Pure Perl module. +( Perl better than 5.008 is recommended) + +Module variables ($JSON::*) were abolished. + +JSON::PP will be renamed JSON (JSON-2.0). + +Many things including error handling are learned from L. +For t/02_error.t compatible, error messages was copied partially from JSON::XS. + + +=head2 FEATURES + +=over + +=item * perhaps correct unicode handling + +This module knows how to handle Unicode (perhaps), +but not yet documents how and when it does so. + +In Perl5.6x, Unicode handling requires L module. + +Perl 5.005_xx, Unicode handling is disable currenlty. + + +=item * round-trip integrity + +This module solved the problem pointed out by JSON::XS +using L module. + +=item * strict checking of JSON correctness + +I want to bring close to XS. +How do you want to carry out? + +you can set C decoding method. + +=item * slow + +Compared to other JSON modules, this module does not compare +favourably in terms of speed. Very slowly! + +=item * simple to use + +This module became very simple. +Since its interface were anyway made the same as JSON::XS. + + +=item * reasonably versatile output formats + +See to L. + +=back + +=head1 FUNCTIONS + +=over + +=item to_json + +See to JSON::XS. +C is an alias. + +=item from_json + +See to JSON::XS. +C is an alias. + + +=item JSON::true + +Returns JSON true value which is blessed object. +It C JSON::Literal object. + +=item JSON::false + +Returns JSON false value which is blessed object. +It C JSON::Literal object. + + +=item JSON::null + +Returns JSON null value which is blessed object. +It C JSON::Literal object. + + +=back + + +=head1 METHODS + +=over + +=item new + +Returns JSON::PP object. + +=item ascii + +See to JSON::XS. + +In Perl 5.6, this method requires L. +If you don't have Unicode::String, +the method is always set to false and warns. + +In Perl 5.005, this option is currently disable. + + +=item latin1 + +See to JSON::XS. + +In Perl 5.6, this method requires L. +If you don't have Unicode::String, +the method is always set to false and warns. + +In Perl 5.005, this option is currently disable. + + +=item utf8 + +See to JSON::XS. + +Currently this module always handles UTF-16 as UTF-16BE. + +=item pretty + +See to JSON::XS. + +=item indent + +See to JSON::XS. +Strictly, this module does not carry out equivalent to XS. + + $json->indent(4); + +is not the same as this: + + $json->indent(); + + +=item space_before + +See to JSON::XS. + +=item space_after + +See JSON::XS. + +=item canonical + +See to JSON::XS. +Strictly, this module does not carry out equivalent to XS. +This method can take a subref for sorting (see to L). + + +=item allow_nonref + +See to JSON::XS. + +=item shrink + +Not yet implemented. + +=item max_depth + +See to JSON::XS. +Strictly, this module does not carry out equivalent to XS. +By default, not 512 (JSON::XS) but 32. + +=item encode + +See to JSON::XS. + +=item decode + +See to JSON::XS. +In Perl 5.6, if you don't have Unicode::String, +the method can't handle UTF-16(BE) char and returns as is. + + +=item property + +Accessor. + + $json->property(utf8 => 1); # $json->utf8(1); + + $value = $json->property('utf8'); # returns 1. + + +=item self_encode + +See L's I function. + + +=item disable_UTF8 + +If this option is set, UTF8 flag in strings generated +by C/C is off. + + +=item allow_tied + +Enable. + +This option will be obsoleted. + + +=item singlequote + +Allows to decode single quoted strings. + +Unlike L module, this module does not encode +Perl string into single quoted string any longer. + + +=item allow_barekey + +Allows to decode bare key of member. + + +=item allow_bigint + +When json text has any integer in decoding more than Perl can't handle, +If this option is on, they are converted into L objects. + + +=item strict + +For JSON format, unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid and +JSON::XS decodes just like that. While this module can deocde thoese. +But if this option is set, the module strictly decodes. + + +=item escape_slash + +By default, JSON::PP encodes strings without escaping slash (U+002F). +Setting the option to escape slash. + + +=item literal_value + + + +=back + + +=head1 MAPPING + + + +=head1 COMPARISON + +Using a benchmark program in the JSON::XS (v1.11) distribution. + + module | encode | decode | + -----------|------------|------------| + JSON::PP | 11092.260 | 4482.033 | + -----------+------------+------------+ + JSON::XS | 341513.380 | 226138.509 | + -----------+------------+------------+ + +In case t/12_binary.t (JSON::XS distribution). +(shrink of JSON::PP has no effect.) + +JSON::PP takes 147 (sec). + +JSON::XS takes 4. + + +=head1 TODO + +=over + +=item Document! + +It is troublesome. + +=item clean up + +Under the cleaning. + +=back + + +=head1 SEE ALSO + +L, L + +RFC4627 + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/qooxdoo/source/perl/JSON/PP5005.pm b/qooxdoo/source/perl/JSON/PP5005.pm new file mode 100755 index 0000000..c7000b1 --- /dev/null +++ b/qooxdoo/source/perl/JSON/PP5005.pm @@ -0,0 +1,82 @@ +package JSON::PP5005; + +use 5.005; +use strict; + +my @properties; + +$JSON::PP5005::VERSION = '0.05'; + +BEGIN { + *JSON::PP::JSON_encode_ascii = *_encode_ascii; + *JSON::PP::JSON_encode_latin1 = *_encode_latin1; + *JSON::PP::JSON_decode_unicode = *_disable_decode_unicode; + + sub utf8::is_utf8 { + 1; # It is considered that UTF8 flag on for Perl 5.005. + } + + sub utf8::encode (\$) { + } + + sub utf8::decode (\$) { + } + + sub JSON::PP::ascii { + warn "ascii() is disable in Perl5.005."; + $_[0]->{ascii} = 0; $_[0]; + } + + sub JSON::PP::latin1 { + warn "latin1() is disable in Perl5.005."; + $_[0]->{latin1} = 0; $_[0]; + } + + # missing in B module. + sub B::SVf_IOK () { 0x00010000; } + sub B::SVf_NOK () { 0x00020000; } + +} + + +sub _encode_ascii { + # currently noop +} + + +sub _encode_latin1 { + # currently noop +} + + +sub _disable_decode_unicode { chr(hex($_[0])); } + + + +1; +__END__ + +=pod + +=head1 NAME + +JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005 + +=head1 DESCRIPTION + +JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/qooxdoo/source/perl/JSON/PP56.pm b/qooxdoo/source/perl/JSON/PP56.pm new file mode 100755 index 0000000..2948908 --- /dev/null +++ b/qooxdoo/source/perl/JSON/PP56.pm @@ -0,0 +1,184 @@ +package JSON::PP56; + +use 5.006; +use strict; + +my @properties; + +$JSON::PP56::VERSION = '0.13'; + +BEGIN { + sub utf8::is_utf8 { + 1; # It is considered that UTF8 flag on for Perl 5.6. + } + + sub utf8::encode (\$) { # UTF8 flag off + ${$_[0]} = pack("C*", unpack("C*", ${$_[0]})); + } + + sub utf8::decode (\$) { # UTF8 flag on + ${$_[0]} = pack("U*", unpack_emu(${$_[0]})); + } +} + +eval q| require Unicode::String |; + +unless ($@) { + #print Unicode::String->VERSION; + if (Unicode::String->VERSION < 2.08) { # utf16be() exists more than v2.08 + eval q| *Unicode::String::utf16be = *Unicode::String::utf16 |; + } + + *JSON::PP::JSON_encode_ascii = *_encode_ascii; + *JSON::PP::JSON_encode_latin1 = *_encode_latin1; + *JSON::PP::JSON_decode_unicode = *JSON::PP::_decode_unicode; + + eval q| + sub Encode::encode { + my (undef, $str) = @_; + my $u = new Unicode::String; + $u->utf8($str); + $u->utf16be; + } + + sub Encode::decode { + my (undef, $str) = @_; + my $u = new Unicode::String; + $u->utf16be($str); + my $utf8 = $u->utf8; + pack("U", unpack("U", $utf8)); # UTF8 flag on + } + + |; + die $@ if ($@); + + $JSON::PP::_ENABLE_UTF16 = 1; + + push @JSON::PP::_properties, 'ascii', 'latin1'; +} +else { + *JSON::PP::JSON_encode_ascii = *_noop_encode_ascii; + *JSON::PP::JSON_decode_unicode = *_disable_decode_unicode; + + eval q| + sub JSON::PP::ascii { + warn "ascii() is disable in Perl5.6x."; + $_[0]->{ascii} = 0; $_[0]; + } + + sub JSON::PP::latin1 { + warn "latin1() is disable in Perl5.6x."; + $_[0]->{latin1} = 0; $_[0]; + } + |; +} + + +sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : + join("", map { '\u' . $_ } + unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); + } unpack_emu($_[0]) + ); +} + + +sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : + join("", map { '\u' . $_ } + unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); + } unpack_emu($_[0]) + ); +} + + +sub unpack_emu { # for Perl 5.6 unpack warnings + my $str = $_[0]; + my @ret; + my $is_utf8; + + while ($str =~ /(?: + ( + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + ) + | (.) + )/xg) + { + if (defined $1) { + $is_utf8 = 1 if (!defined $is_utf8); + if ($is_utf8) { + push @ret, unpack('U', $1); + } + else { + push @ret, unpack('C*', $1); + } + } + else { + $is_utf8 = 0 if (!defined $is_utf8); + + if ($is_utf8) { # eventually, not utf8 + return unpack('C*', $str); + } + + push @ret, unpack('C', $2); + } + } + + return @ret; +} + + + +sub _noop_encode_ascii { + # noop +} + + +sub _disable_decode_unicode { chr(hex($_[0])); } + + +1; +__END__ + +=pod + +=head1 NAME + +JSON::PP56 - Helper module in using JSON::PP in Perl 5.6 + +=head1 DESCRIPTION + +JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/qooxdoo/source/perl/JSON/Parser.pm b/qooxdoo/source/perl/JSON/Parser.pm new file mode 100755 index 0000000..7c4e8b4 --- /dev/null +++ b/qooxdoo/source/perl/JSON/Parser.pm @@ -0,0 +1,419 @@ +package JSON::Parser; + +# +# Perl implementaion of json.js +# http://www.crockford.com/JSON/json.js +# + +use vars qw($VERSION $USE_UTF8 $USE_UnicodeString); +use strict; +use JSON (); +use Carp (); + +BEGIN { # suggested by philip.tellis[at]gmail.com + if ($] < 5.008) { + eval q{ require Unicode::String }; + unless ($@) { + $USE_UnicodeString = 1; + eval q| + sub utf8::encode (\$) { + my $f_ref = $_[0]; + if (length($$f_ref) == 1 && ord($$f_ref) <= 0xff) { + my $us = new Unicode::String; + $us->latin1($$f_ref); + $$f_ref = $us->utf8; + } + } + |; + } + } +} + + +$VERSION = '1.07'; + +# TODO: I made 1.03, but that will be used after JSON 1.90 + +$USE_UTF8 = JSON->USE_UTF8(); + +my %escapes = ( # by Jeremy Muhlich + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", +# '/' => '/', + '\\' => '\\', +); + + +sub new { + my $class = shift; + bless { @_ }, $class; +} + + +*jsonToObj = \&parse; + + +{ # PARSE + + my $text; + my $at; + my $ch; + my $len; + my $unmap; # unmmaping + my $bare; # bareKey + my $apos; # loosely quoting + my $utf8; # set utf8 flag + + + sub parse { + my $self = shift; + $text = shift; + $at = 0; + $ch = ''; + $len = length $text; + $self->_init(@_); + value(); + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return string() if($ch eq '"' or ($apos and $ch eq "'")); + return number() if($ch eq '-'); + return $ch =~ /\d/ ? number() : word(); + } + + + sub string { + my ($i,$s,$t,$u); + $s = ''; + + if($ch eq '"' or ($apos and $ch eq "'")){ + my $boundChar = $ch if ($apos); + + OUTER: while( defined(next_chr()) ){ + if((!$apos and $ch eq '"') or ($apos and $ch eq $boundChar)){ + next_chr(); + $utf8 and utf8::decode($s); + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ + my $u = ''; + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[\da-fA-F]/); + $u .= $ch; + } + my $f = chr(hex($u)); + utf8::encode( $f ) if($USE_UTF8 || $USE_UnicodeString); + $s .= $f; + } + else{ + $s .= $ch; + } + } + else{ + $s .= $ch; + } + } + } + + error("Bad string"); + } + + + sub white { + while( defined $ch ){ + if($ch le ' '){ + next_chr(); + } + elsif($ch eq '/'){ + next_chr(); + if($ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif($ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + error("Unterminated comment"); + } + } + next; + } + else{ + error("Syntax error (whitespace)"); + } + } + else{ + last; + } + } + } + + + sub object { + my $o = {}; + my $k; + + if($ch eq '{'){ + next_chr(); + white(); + if($ch eq '}'){ + next_chr(); + return $o; + } + while(defined $ch){ + $k = ($bare and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if($ch ne ':'){ + last; + } + + next_chr(); + $o->{$k} = value(); + white(); + + if($ch eq '}'){ + next_chr(); + return $o; + } + elsif($ch ne ','){ + last; + } + next_chr(); + white(); + } + + error("Bad object"); + } + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return $unmap ? 1 : bless {value => 'true'}, 'JSON::NotString' + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return $unmap ? undef : bless {value => undef}, 'JSON::NotString'; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return $unmap ? 0 : bless {value => 'false'}, 'JSON::NotString' + } + } + + error("Syntax error (word)"); + } + + + sub number { + my $n = ''; + my $v; + + if($ch eq '0'){ + my $peek = substr($text,$at,1); + my $hex = $peek =~ /[xX]/; + + if($hex){ + ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); + } + else{ + ($n) = ( substr($text, $at) =~ /^([0-7]+)/); + } + + if(defined $n and length($n)){ + $at += length($n) + $hex; + next_chr; + return $hex ? hex($n) : oct($n); + } + } + + if($ch eq '-'){ + $n = '-'; + next_chr; + } + + while($ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if($ch eq '.'){ + $n .= '.'; + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if($ch eq 'e' or $ch eq 'E'){ + $n .= $ch; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-' or $ch =~ /\d/)){ + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + return 0+$v; + } + + + sub array { + my $a = []; + + if($ch eq '['){ + next_chr(); + white(); + if($ch eq ']'){ + next_chr(); + return $a; + } + while(defined($ch)){ + push @$a, value(); + white(); + if($ch eq ']'){ + next_chr(); + return $a; + } + elsif($ch ne ','){ + last; + } + next_chr(); + white(); + } + } + + error("Bad array"); + } + + + sub error { + my $error = shift; + + local $Carp::CarpLevel = 1; + + my $str = substr($text, $at); + + unless (length $str) { $str = '(end of string)'; } + + Carp::croak "$error, at character offset $at ($str)"; + } + + + sub _init { + my $opt = $_[1] || {}; + $unmap= $_[0]->{unmapping}; + $unmap= $opt->{unmapping} if(exists $opt->{unmapping}); + $bare = $_[0]->{barekey}; + $bare = $opt->{barekey} if(exists $opt->{barekey}); + $apos = $_[0]->{quotapos}; + $apos = $opt->{quotapos} if(exists $opt->{quotapos}); + $utf8 = $_[0]->{utf8}; + $utf8 = $opt->{utf8} if(exists $opt->{utf8}); + if($utf8 and !$USE_UTF8){ $utf8 = 0; warn "JSON::Parser couldn't use utf8."; } + } + +} # PARSE + + + + +package JSON::NotString; + +use overload ( + '""' => sub { $_[0]->{value} }, + 'bool' => sub { + ! defined $_[0]->{value} ? undef + : $_[0]->{value} eq 'false' ? 0 : 1; + }, + 'eq' => sub { (defined $_[0]->{value} ? $_[0]->{value} : 'null') eq $_[1] }, + 'ne' => sub { (defined $_[0]->{value} ? $_[0]->{value} : 'null') ne $_[1] }, + '==' => sub { (!defined $_[0]->{value} ? -1 : $_[0]->{value} eq 'false' ? 0 : 1) == $_[1] }, + '!=' => sub { (!defined $_[0]->{value} ? -1 : $_[0]->{value} eq 'false' ? 0 : 1) != $_[1] }, +); + +1; + +__END__ + + 'eq' => sub { + if (ref($_[1]) eq 'JSON::NotString') { + return $_[0]->{value} eq $_[1]->{value}; + } + else { + return $_[0]->{value} eq $_[1]; + } + }, + + +=head1 SEE ALSO + +L + +This module is an implementation of L. + + +=head1 COPYRIGHT + +makamaka [at] donzoko.net + +This library is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=cut diff --git a/qooxdoo/source/perl/Qooxdoo/JSONRPC.pm b/qooxdoo/source/perl/Qooxdoo/JSONRPC.pm new file mode 100644 index 0000000..bf4541d --- /dev/null +++ b/qooxdoo/source/perl/Qooxdoo/JSONRPC.pm @@ -0,0 +1,957 @@ +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); + + 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 eq '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); + + print STDERR "JSON received: $input\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)'; + + 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 !~ 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_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 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 Enick.glencross@gmail.comE + +=cut + + +1; diff --git a/qooxdoo/source/perl/Qooxdoo/Services/Smokeping.pm b/qooxdoo/source/perl/Qooxdoo/Services/Smokeping.pm new file mode 100644 index 0000000..f40288d --- /dev/null +++ b/qooxdoo/source/perl/Qooxdoo/Services/Smokeping.pm @@ -0,0 +1,34 @@ +package Qooxdoo::Services::Smokeping; +use strict; + +sub GetAccessibility { + return "public"; +} + +sub method_get_tree +{ + my $error = shift; +# $error->set_error(101,$err); +# return $error; + # b = branche + # i = in + # l = leave + # o = out + return [ ['fk1','Folder 1', + 'fk1/f1','File 1', + 'fk1/f2','File 2', + [ 'fk1/sf1','Sub Folder 2', + 'fk1/sf1/f3','File 3', + 'fk1/sf1/f4','File 4', + ], + ], + [ 'fk2','Folder 2'], + [ 'fk3','Folder 3', + 'fk3/f3','File 33', + 'fk3/f4','File 44' + ] + ] +} + +1; + diff --git a/qooxdoo/source/resource/image/ajax-loader.gif b/qooxdoo/source/resource/image/ajax-loader.gif new file mode 100644 index 0000000..4a78acb Binary files /dev/null and b/qooxdoo/source/resource/image/ajax-loader.gif differ diff --git a/qooxdoo/source/script/Smokeping.js b/qooxdoo/source/script/Smokeping.js new file mode 100644 index 0000000..53670e4 --- /dev/null +++ b/qooxdoo/source/script/Smokeping.js @@ -0,0 +1,168 @@ +document.write('\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +\ +'); \ No newline at end of file diff --git a/qooxdoo/source/translation/C.po b/qooxdoo/source/translation/C.po new file mode 100644 index 0000000..6812b97 --- /dev/null +++ b/qooxdoo/source/translation/C.po @@ -0,0 +1,20 @@ +# Language C translations for PACKAGE package. +# Copyright (C) 2007 THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# Automatically generated, 2007. +# +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2007-11-14 11:29-0600\n" +"PO-Revision-Date: 2007-10-19 09:30+0200\n" +"Last-Translator: Automatically generated\n" +"Language-Team: none\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=ASCII\n" +"Content-Transfer-Encoding: 8bit\n" + +#: source/class/Smokeping/Application.js:47 +msgid "Root Node" +msgstr "" diff --git a/qooxdoo/source/translation/de.po b/qooxdoo/source/translation/de.po new file mode 100644 index 0000000..eb3d833 --- /dev/null +++ b/qooxdoo/source/translation/de.po @@ -0,0 +1,223 @@ +# German translations for PACKAGE package. ö +# Copyright (C) 2007 THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# Automatically generated, 2007. +# +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2007-11-14 11:29-0600\n" +"PO-Revision-Date: 2007-10-19 09:30+0200\n" +"Last-Translator: Automatically generated\n" +"Language-Team: none\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=utf-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=(n != 1);\n" + +#: source/class/Smokeping/Application.js:47 +msgid "Root Node" +msgstr "" + +#~ msgid "Start Date" +#~ msgstr "Start-Datum" + +#, fuzzy +#~ msgid "Time" +#~ msgstr "Titel" + +#~ msgid "End Date" +#~ msgstr "End-Datum" + +#~ msgid "Location" +#~ msgstr "Standort" + +#~ msgid "Data Source" +#~ msgstr "Daten-Quelle" + +#~ msgid "Data Massage" +#~ msgstr "Daten Massage" + +#~ msgid "Location/Client" +#~ msgstr "Standort/GWP" + +#~ msgid "Data Filter" +#~ msgstr "Daten-Filter" + +#~ msgid "Y axis" +#~ msgstr "Y-Achse" + +#~ msgid "Plot Data" +#~ msgstr "Grafik erzeugen" + +#~ msgid "Open in Excel" +#~ msgstr "Oeffne in Excel" + +#~ msgid "Please make sure all entries in the form are valid!" +#~ msgstr "Alle Felder müssen gültige Werte enhalten!" + +#, fuzzy +#~ msgid "Snap" +#~ msgstr "Sonntag" + +#~ msgid "Client" +#~ msgstr "GWP" + +#~ msgid "Hostname" +#~ msgstr "GWP" + +#~ msgid "Team" +#~ msgstr "Team" + +#~ msgid "Ip" +#~ msgstr "Ip" + +#~ msgid "User" +#~ msgstr "Benutzer" + +#~ msgid "CPV" +#~ msgstr "CPV" + +#~ msgid "Last Update" +#~ msgstr "Letztes Update" + +#~ msgid "Low" +#~ msgstr "Tief" + +#~ msgid "Filter out values lower than this" +#~ msgstr "Keine Werte tiefer als dieser" + +#~ msgid "High" +#~ msgstr "Hoch" + +#, fuzzy +#~ msgid "Filter out values higher than this" +#~ msgstr "Keine Werte höher als dieser" + +#, fuzzy +#~ msgid "Data Set 1" +#~ msgstr "Daten-Quelle" + +#~ msgid "Name" +#~ msgstr "Name" + +#, fuzzy +#~ msgid "Title" +#~ msgstr "Titel" + +#~ msgid "Unit" +#~ msgstr "Einheit" + +#, fuzzy +#~ msgid "Data Set 2" +#~ msgstr "Daten-Quelle" + +#, fuzzy +#~ msgid "Start" +#~ msgstr "Start" + +#~ msgid "End" +#~ msgstr "Ende" + +#~ msgid "From" +#~ msgstr "Von" + +#~ msgid "To" +#~ msgstr "bis" + +#, fuzzy +#~ msgid "Time filter: Use only data in the specified time range" +#~ msgstr "Zeitfilter: Verwende nur Daten für den angegebenen Zeitraum" + +#~ msgid "DOW" +#~ msgstr "Wochentag" + +#, fuzzy +#~ msgid "Weekday filter: Use only data for the selected weekday" +#~ msgstr "Wochentag: Verwende nur Daten fuer den ausgewaehlten Wochentag" + +#~ msgid "Monday" +#~ msgstr "Montag" + +#~ msgid "Tuesday" +#~ msgstr "Dienstag" + +#~ msgid "Wednesday" +#~ msgstr "Mittwoch" + +#~ msgid "Thursday" +#~ msgstr "Donnerstag" + +#~ msgid "Friday" +#~ msgstr "Freitag" + +#~ msgid "Saturday" +#~ msgstr "Samstag" + +#~ msgid "Sunday" +#~ msgstr "Sonntag" + +#~ msgid "Start value for y-axis" +#~ msgstr "Startwert für die y-Achse" + +#~ msgid "End value for y-axis" +#~ msgstr "Endwert für die y-Achse" + +#~ msgid "Merge" +#~ msgstr "Ueberlagern" + +#, fuzzy +#~ msgid "day" +#~ msgstr "Tag" + +#~ msgid "1 week" +#~ msgstr "1 Woche" + +#~ msgid "2 weeks" +#~ msgstr "2 Wochen" + +#~ msgid "3 weeks" +#~ msgstr "3 Wochen" + +#~ msgid "4 weeks" +#~ msgstr "4 Wochen" + +#~ msgid "Contents" +#~ msgstr "Inhalt" + +#~ msgid "Scale" +#~ msgstr "Skalierung" + +#~ msgid "Time series" +#~ msgstr "Zeitreihe" + +#~ msgid "Histogram" +#~ msgstr "Histogramm" + +#~ msgid "Bins" +#~ msgstr "Zeitbereiche" + +#, fuzzy +#~ msgid "Bin data (for mean/median and histograms)" +#~ msgstr "" +#~ "Anzahl der Zeitbereiche für die Berechnung\n" +#~ "von Durchschnitts/Median-Werten und Histogrammen" + +#, fuzzy +#~ msgid "Message:" +#~ msgstr "Ueberlagern" + +#, fuzzy +#~ msgid "Fetch Data" +#~ msgstr "Grafik erzeugen" + +#~ msgid "Graph Window" +#~ msgstr "Grafik Fenster" + +#, fuzzy +#~ msgid "Choose language" +#~ msgstr "Sprachauswahl: " + +#~ msgid "Data" +#~ msgstr "Daten" diff --git a/qooxdoo/source/translation/en.po b/qooxdoo/source/translation/en.po new file mode 100644 index 0000000..2c63469 --- /dev/null +++ b/qooxdoo/source/translation/en.po @@ -0,0 +1,202 @@ +# English translations for PACKAGE package. +# Copyright (C) 2007 THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# Automatically generated, 2007. +# +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2007-11-14 11:29-0600\n" +"PO-Revision-Date: 2007-10-26 23:25+0200\n" +"Last-Translator: Automatically generated\n" +"Language-Team: none\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=ASCII\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=(n != 1);\n" + +#: source/class/Smokeping/Application.js:47 +msgid "Root Node" +msgstr "" + +#~ msgid "Start Date" +#~ msgstr "Start Date" + +#, fuzzy +#~ msgid "Time" +#~ msgstr "Title" + +#~ msgid "End Date" +#~ msgstr "End Date" + +#~ msgid "Location" +#~ msgstr "Location" + +#~ msgid "Data Source" +#~ msgstr "Data Source" + +#~ msgid "Data Massage" +#~ msgstr "Data Massage" + +#~ msgid "Location/Client" +#~ msgstr "Location/Client" + +#~ msgid "Data Filter" +#~ msgstr "Data Filter" + +#~ msgid "Y axis" +#~ msgstr "Y axis" + +#~ msgid "Plot Data" +#~ msgstr "Plot Data" + +#~ msgid "Open in Excel" +#~ msgstr "Open in Excel" + +#~ msgid "Please make sure all entries in the form are valid!" +#~ msgstr "Please make sure all entries in the form are valid!" + +#, fuzzy +#~ msgid "Snap" +#~ msgstr "Sunday" + +#~ msgid "Client" +#~ msgstr "Client" + +#~ msgid "Low" +#~ msgstr "Low" + +#~ msgid "Filter out values lower than this" +#~ msgstr "Filter out values lower than this" + +#~ msgid "High" +#~ msgstr "High" + +#~ msgid "Filter out values higher than this" +#~ msgstr "Filter out values higher than this" + +#, fuzzy +#~ msgid "Data Set 1" +#~ msgstr "Data Source" + +#~ msgid "Name" +#~ msgstr "Name" + +#~ msgid "Title" +#~ msgstr "Title" + +#~ msgid "Unit" +#~ msgstr "Unit" + +#, fuzzy +#~ msgid "Data Set 2" +#~ msgstr "Data Source" + +#~ msgid "Start" +#~ msgstr "Start" + +#~ msgid "End" +#~ msgstr "End" + +#~ msgid "From" +#~ msgstr "From" + +#~ msgid "To" +#~ msgstr "To" + +#~ msgid "Time filter: Use only data in the specified time range" +#~ msgstr "Time filter: Use only data in the specified time range" + +#~ msgid "DOW" +#~ msgstr "DOW" + +#~ msgid "Weekday filter: Use only data for the selected weekday" +#~ msgstr "Weekday filter: Use only data for the selected weekday" + +#~ msgid "Monday" +#~ msgstr "Monday" + +#~ msgid "Tuesday" +#~ msgstr "Tuesday" + +#~ msgid "Wednesday" +#~ msgstr "Wednesday" + +#~ msgid "Thursday" +#~ msgstr "Thursday" + +#~ msgid "Friday" +#~ msgstr "Friday" + +#~ msgid "Saturday" +#~ msgstr "Saturday" + +#~ msgid "Sunday" +#~ msgstr "Sunday" + +#~ msgid "y-min" +#~ msgstr "y-min" + +#~ msgid "y-max" +#~ msgstr "y-max" + +#~ msgid "Merge" +#~ msgstr "Merge" + +#~ msgid "day" +#~ msgstr "day" + +#~ msgid "1 week" +#~ msgstr "1 week" + +#~ msgid "2 weeks" +#~ msgstr "2 weeks" + +#~ msgid "3 weeks" +#~ msgstr "3 weeks" + +#~ msgid "4 weeks" +#~ msgstr "4 weeks" + +#~ msgid "Contents" +#~ msgstr "Contents" + +#~ msgid "Fit" +#~ msgstr "Fit" + +#~ msgid "Scale" +#~ msgstr "Scale" + +#~ msgid "Time series" +#~ msgstr "Time series" + +#~ msgid "Histogram" +#~ msgstr "Histogram" + +#~ msgid "Bins" +#~ msgstr "Bins" + +#, fuzzy +#~ msgid "Bin data (for mean/median and histograms)" +#~ msgstr "" +#~ "Number of date ranges for calculation\n" +#~ " of mean/median values and histogram bins" + +#, fuzzy +#~ msgid "Message:" +#~ msgstr "Merge" + +#, fuzzy +#~ msgid "Fetch Data" +#~ msgstr "Plot Data" + +#~ msgid "Graph Window" +#~ msgstr "Graph Window" + +#, fuzzy +#~ msgid "Choose language" +#~ msgstr "Choose language: " + +#~ msgid "Data" +#~ msgstr "Data" diff --git a/qooxdoo/source/translation/fr.po b/qooxdoo/source/translation/fr.po new file mode 100644 index 0000000..5245d60 --- /dev/null +++ b/qooxdoo/source/translation/fr.po @@ -0,0 +1,21 @@ +# French translations for PACKAGE package. +# Copyright (C) 2007 THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# Automatically generated, 2007. +# +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2007-11-14 11:29-0600\n" +"PO-Revision-Date: 2007-10-19 09:30+0200\n" +"Last-Translator: Automatically generated\n" +"Language-Team: none\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=ASCII\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=(n > 1);\n" + +#: source/class/Smokeping/Application.js:47 +msgid "Root Node" +msgstr "" diff --git a/qooxdoo/source/translation/it.po b/qooxdoo/source/translation/it.po new file mode 100644 index 0000000..42205ba --- /dev/null +++ b/qooxdoo/source/translation/it.po @@ -0,0 +1,183 @@ +# Italian translations for PACKAGE package. +# Copyright (C) 2007 THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# Automatically generated, 2007. +# +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2007-10-22 21:36+0200\n" +"PO-Revision-Date: 2007-10-19 09:30+0200\n" +"Last-Translator: Automatically generated\n" +"Language-Team: none\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=ASCII\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=(n != 1);\n" + +#: source/class/CPVexplorer/Application.js:78 +msgid "Data Source" +msgstr "" + +#: source/class/CPVexplorer/Application.js:82 +#: source/class/CPVexplorer/Application.js:124 +#: source/class/CPVexplorer/ui/PlotSelector.js:52 +msgid "Plot Data" +msgstr "" + +#: source/class/CPVexplorer/Application.js:106 +msgid "Location/Client" +msgstr "" + +#: source/class/CPVexplorer/Application.js:110 +msgid "Data Filter" +msgstr "" + +#: source/class/CPVexplorer/Application.js:114 +msgid "Y axis" +msgstr "" + +#: source/class/CPVexplorer/Application.js:126 +msgid "Open in Excel" +msgstr "" + +#: source/class/CPVexplorer/Application.js:301 +msgid "Choose language: " +msgstr "" + +#: source/class/CPVexplorer/ui/ClientSelector.js:36 +msgid "Location" +msgstr "" + +#: source/class/CPVexplorer/ui/ClientSelector.js:45 +msgid "Client" +msgstr "" + +#: source/class/CPVexplorer/ui/DataFilter.js:36 +msgid "Low" +msgstr "" + +#: source/class/CPVexplorer/ui/DataFilter.js:46 +msgid "High" +msgstr "" + +#: source/class/CPVexplorer/ui/DataSelector.js:37 +msgid "Data" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:61 +msgid "Start" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:75 +msgid "Start Date" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:80 +msgid "End" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:91 +msgid "End Date" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:95 +msgid "From" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:106 +msgid "To" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:116 +msgid "Time filter: Use only data in the specified time range" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:121 +msgid "DOW" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:129 +msgid "Weekday filter: Use only data for the selected weekday" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:137 +msgid "Monday" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:139 +msgid "Tuesday" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:141 +msgid "Wednesday" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:143 +msgid "Thursday" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:145 +msgid "Friday" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:147 +msgid "Saturday" +msgstr "" + +#: source/class/CPVexplorer/ui/DateSelector.js:149 +msgid "Sunday" +msgstr "" + +#: source/class/CPVexplorer/ui/DefineAxes.js:36 +msgid "y-min" +msgstr "" + +#: source/class/CPVexplorer/ui/DefineAxes.js:47 +msgid "y-max" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:27 +msgid "Merge" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:38 +msgid "day" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:40 +msgid "1 week" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:42 +msgid "2 weeks" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:44 +msgid "3 weeks" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:46 +msgid "4 weeks" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:75 +msgid "Fit" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:111 +msgid "Scale" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:135 +msgid "Time series" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:143 +msgid "Histogram" +msgstr "" + +#: source/class/CPVexplorer/ui/PlotSelector.js:153 +msgid "Bins" +msgstr "" diff --git a/qooxdoo/source/translation/messages.pot b/qooxdoo/source/translation/messages.pot new file mode 100644 index 0000000..27889a3 --- /dev/null +++ b/qooxdoo/source/translation/messages.pot @@ -0,0 +1,21 @@ +# SOME DESCRIPTIVE TITLE. +# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# FIRST AUTHOR , YEAR. +# +#, fuzzy +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2007-11-14 11:29-0600\n" +"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=CHARSET\n" +"Content-Transfer-Encoding: 8bit\n" + +#: source/class/Smokeping/Application.js:47 +msgid "Root Node" +msgstr "" -- cgit v1.2.3-24-g4f1b