[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

SF.net SVN: ledger-smb:[4977] trunk



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.