[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
SF.net SVN: ledger-smb:[4977] trunk
- Subject: SF.net SVN: ledger-smb:[4977] trunk
- From: ..hidden..
- Date: Fri, 13 Jul 2012 16:01:36 +0000
Revision: 4977
http://ledger-smb.svn.sourceforge.net/ledger-smb/?rev=4977&view=rev
Author: einhverfr
Date: 2012-07-13 16:01:36 +0000 (Fri, 13 Jul 2012)
Log Message:
-----------
XML get for contacts now working. JSON not working yet
Modified Paths:
--------------
trunk/LedgerSMB/DBObject/Entity/Company.pm
trunk/LedgerSMB/DBObject/Entity/Location.pm
trunk/LedgerSMB/REST_Class/Contact.pm
trunk/LedgerSMB/REST_Format/json.pm
trunk/LedgerSMB/REST_Format/xml.pm
trunk/LedgerSMB.pm
trunk/rest-handler.pl
Modified: trunk/LedgerSMB/DBObject/Entity/Company.pm
===================================================================
--- trunk/LedgerSMB/DBObject/Entity/Company.pm 2012-07-13 07:54:45 UTC (rev 4976)
+++ trunk/LedgerSMB/DBObject/Entity/Company.pm 2012-07-13 16:01:36 UTC (rev 4977)
@@ -95,11 +95,11 @@
sub get {
my ($self, $id) = @_;
- my ($ref) = $self->call_procedure(procname => 'company__get',
+ my ($ref) = LedgerSMB::DBObject::Entity->call_procedure(procname => 'company__get',
args => [$id]);
return undef unless $ref->{control_code};
- $self->prepare_dbhash($ref);
- return $self->new(%$ref);
+ __PACKAGE__->prepare_dbhash($ref);
+ return __PACKAGE__->new(%$ref);
}
=item get_by_cc($cc)
Modified: trunk/LedgerSMB/DBObject/Entity/Location.pm
===================================================================
--- trunk/LedgerSMB/DBObject/Entity/Location.pm 2012-07-13 07:54:45 UTC (rev 4976)
+++ trunk/LedgerSMB/DBObject/Entity/Location.pm 2012-07-13 16:01:36 UTC (rev 4977)
@@ -20,8 +20,16 @@
package LedgerSMB::DBObject::Entity::Location;
use Moose;
+use LedgerSMB::App_State;
+use LedgerSMB::Locale;
extends 'LedgerSMB::DBObject_Moose';
+my $locale = $LedgerSMB::App_State::Locale;
+if (!$locale){
+ $locale = LedgerSMB::Locale->get_handle('en');
+ warn 'default language used';
+}
+
=back
=head1 PROPERTIES
@@ -103,9 +111,9 @@
=cut
-our %classes = ( 1 => $LedgerSMB::App_State::Locale->text('Billing'),
- 2 => $LedgerSMB::App_State::Locale->text('Sales'),
- 3 => $LedgerSMB::App_State::Locale->text('Shipping'),
+our %classes = ( 1 => $locale->text('Billing'),
+ 2 => $locale->text('Sales'),
+ 3 => $locale->text('Shipping'),
);
has 'class_name' => (is => 'rw', isa => 'Maybe[Str]');
Modified: trunk/LedgerSMB/REST_Class/Contact.pm
===================================================================
--- trunk/LedgerSMB/REST_Class/Contact.pm 2012-07-13 07:54:45 UTC (rev 4976)
+++ trunk/LedgerSMB/REST_Class/Contact.pm 2012-07-13 16:01:36 UTC (rev 4977)
@@ -6,7 +6,7 @@
package LedgerSMB::REST_Class::Contact;
use LedgerSMB::DBObject::Entity;
-use LedgerSMB::DBObject::Entity::Credit_Acount;
+use LedgerSMB::DBObject::Entity::Credit_Account;
use LedgerSMB::DBObject::Entity::Location;
use LedgerSMB::DBObject::Entity::Contact;
use LedgerSMB::DBObject::Entity::Company;
@@ -34,12 +34,11 @@
=cut
-my $cname = 'LedgerSMB::REST_Class::contact';
+my $cname = 'LedgerSMB::REST_Class::Contact';
sub get {
my ($request) = @_;
- die "418 I'm a Teapot";
- my $id = $request->{$cname};
+ my $id = $request->{classes}->{$cname};
my $data;
if (defined $id){
my $company = LedgerSMB::DBObject::Entity::Company->get($id);
@@ -65,7 +64,7 @@
LedgerSMB::DBObject::Entity::Bank-> list($id);
return $data;
} else {
- ...
+ die "Coming Soon";
}
}
@@ -89,3 +88,4 @@
=cut
+1;
Modified: trunk/LedgerSMB/REST_Format/json.pm
===================================================================
--- trunk/LedgerSMB/REST_Format/json.pm 2012-07-13 07:54:45 UTC (rev 4976)
+++ trunk/LedgerSMB/REST_Format/json.pm 2012-07-13 16:01:36 UTC (rev 4977)
@@ -18,21 +18,27 @@
=cut
+package LedgerSMB::REST_Format::json;
+
use JSON;
use strict;
use warnings;
-local $JSON::UTF8 = 1;
+my $json = JSON->new();
+$json->pretty(1);
+$json->indent(1);
+$json->utf8(1);
+$json->convert_blessed(1);
sub from_input{
my $request = shift @_;
- return decode_json($request->{payload});
+ return $json->decode($request->{payload});
}
sub to_output{
my $request = shift @_;
my $output = shift @_;
- return encode_json($output, { pretty => 1, indent => 2 };
+ return $json->encode($output);
}
1;
Modified: trunk/LedgerSMB/REST_Format/xml.pm
===================================================================
--- trunk/LedgerSMB/REST_Format/xml.pm 2012-07-13 07:54:45 UTC (rev 4976)
+++ trunk/LedgerSMB/REST_Format/xml.pm 2012-07-13 16:01:36 UTC (rev 4977)
@@ -19,6 +19,7 @@
=cut
+package LedgerSMB::REST_Format::xml;
use XML::Simple;
use strict;
use warnings;
Modified: trunk/LedgerSMB.pm
===================================================================
--- trunk/LedgerSMB.pm 2012-07-13 07:54:45 UTC (rev 4976)
+++ trunk/LedgerSMB.pm 2012-07-13 16:01:36 UTC (rev 4977)
@@ -658,7 +658,6 @@
my $argstr = "";
my @results;
my $dbh = $LedgerSMB::App_State::DBH;
- $dbh ||= $self->{dbh};
die 'Database handle not found!' if !$dbh;
if (!defined $procname){
Modified: trunk/rest-handler.pl
===================================================================
--- trunk/rest-handler.pl 2012-07-13 07:54:45 UTC (rev 4976)
+++ trunk/rest-handler.pl 2012-07-13 16:01:36 UTC (rev 4977)
@@ -141,10 +141,24 @@
package LedgerSMB::REST_Handler;
+use FindBin;
+BEGIN {
+ lib->import($FindBin::Bin) unless $ENV{mod_perl}
+}
+
use CGI::Simple;
use Try::Tiny;
+use LedgerSMB::App_State;
+use LedgerSMB::Locale;
use strict;
use warnings;
+
+# Some modules depend on locale being set for error handling, but we want to
+# ensure that only the default language is used to ensure nothing strange
+# happens. So hard-coded to English here. --CT
+my $locale = LedgerSMB::Locale->get_handle('en');
+$LedgerSMB::App_State::Locale = $locale;
+
process_request();
# Note: Indenting try/catch only two characters here because it wraps all
@@ -158,7 +172,7 @@
my $return_info;
if (! eval "require LedgerSMB::REST_Format::" . $format) {
- eval "require LedgerSMB::REST_Format::" . $format;
+ eval "require LedgerSMB::REST_Format::" . $request->{format}
}
my $fmtpackage = "LedgerSMB::REST_Format::" . $format;
@@ -170,43 +184,31 @@
}
}
- my $classpkg = "LedgerSMB::REST_Class::" . $request->{class};
- eval "require $classpkg" || return error_handler('404 Resource Not Found');
-
- my $restobj;
- if ($classpkg->can('new')){
- $restobj = $classpkg->can('new')->($request);
- } else {
- die '500 Bad Class Definition';
+ my $classpkg = $request->{class_name};
+ if (!eval "require $classpkg"){
+ warn $!;
+ warn $@;
+ warn "failed require $classpkg";
+ return error_handler('404 Class Not Found');
}
- if ($request->{subresource}){
+ my $restobj = $classpkg;
- my $suffixed_method = "$request->{subresource}_"
- . lc($request->{method});
- if ($restobj->can($suffixed_method)){
- $restobj->can($suffixed_method)->($request);
- } else {
- $restobj->can($request->{subresource})
- || die '404 Resource Not Found';
- }
+ if ($classpkg->can(lc($request->{method}))){
+ $return_info = $classpkg->can(lc($request->{method}))->($request);
} else {
-
- if ($classpkg->can(lc($request->{method}))){
- $return_info = $classpkg->can(lc($request->{method}))->($request);
- } else {
- die '405 Method Not Allowed';
- }
-
+ die '405 Method Not Allowed';
}
my $content;
my $ctype;
+ warn $fmtpackage;
if ($return_info){
if ($fmtpackage->can('to_output')){
$content = $fmtpackage->can('to_output')->($request, $return_info);
} else {
+ warn 'cannot output';
return error_handler('415 Unsupported Media Type');
}
}
@@ -224,9 +226,15 @@
sub error_handler {
my ($error) = @_;
+ warn $error;
+ # Sometimes the two lines below can be useful for debugging. Note they
+ # turn all errors into internal server errors and populate the logs with
+ # all kinds of stuff --CT
+ #use Carp;
+ #Carp::confess();
my $content = $error;
$content =~ s/^\d\d\d\s//;
- $error =~ s/(.*)\n.*/$1/m;
+ $error =~ s/\n/: /m;
$error =~ s/ at .*//;
if ($error !~ /^\d\d\d/){
$error = "500 $error";
@@ -250,18 +258,19 @@
$request->{method} = $ENV{REQUEST_METHOD};
$request->{payload} = $cgi->param( "$request->{method}DATA" );
$url =~ s|.*/rest-handler.pl/(.*)|$1|;
- $url =~ s|(\.[^/]$)||;
+ $url =~ s|\.([^/.]*$)||;
$request->{format} = $1;
my @components = split /\//, $url;
my $version = shift @components;
+ my $company = shift @components;
die '400 Unsupported Version' if ($version ne '1.4');
-
$request->{dbh} = DBI->connect(
- "dbi:Pg:dbname=$components[0]",
+ "dbi:Pg:dbname=$company",
"$creds->{login}", "$creds->{password}",
{ AutoCommit => 0 }
);
+ $LedgerSMB::App_State::DBH = $request->{dbh};
if (!$request->{dbh}) {
die '401 Unauthorized';
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.