summaryrefslogtreecommitdiff
path: root/LedgerSMB/RESTXML
diff options
context:
space:
mode:
Diffstat (limited to 'LedgerSMB/RESTXML')
-rw-r--r--LedgerSMB/RESTXML/Document/Base.pm52
-rw-r--r--LedgerSMB/RESTXML/Document/Customer.pm27
-rw-r--r--LedgerSMB/RESTXML/Document/Customer_Search.pm91
-rw-r--r--LedgerSMB/RESTXML/Document/Part.pm27
-rw-r--r--LedgerSMB/RESTXML/Document/Part_Search.pm89
-rw-r--r--LedgerSMB/RESTXML/Document/SalesOrder.pm11
-rw-r--r--LedgerSMB/RESTXML/Document/Session.pm15
-rw-r--r--LedgerSMB/RESTXML/Handler.pm207
8 files changed, 285 insertions, 234 deletions
diff --git a/LedgerSMB/RESTXML/Document/Base.pm b/LedgerSMB/RESTXML/Document/Base.pm
index e8feaa96..986b4148 100644
--- a/LedgerSMB/RESTXML/Document/Base.pm
+++ b/LedgerSMB/RESTXML/Document/Base.pm
@@ -5,26 +5,27 @@ use XML::Twig;
use LedgerSMB::Log;
use Carp;
-sub handle_post {
- my ($self, $args) = @_;
+sub handle_post {
+ my ( $self, $args ) = @_;
- return $args->{handler}->unsupported('the POST method is not implemented.');
+ return $args->{handler}->unsupported('the POST method is not implemented.');
}
-sub handle_put {
- my ($self, $args) = @_;
- return $self->{handler}->unsupported('the PUT method is not implemented.');
+sub handle_put {
+ my ( $self, $args ) = @_;
+ return $self->{handler}->unsupported('the PUT method is not implemented.');
}
sub handle_delete {
- my ($self, $args) = @_;
- return $self->{handler}->unsupported('the DELETE method is not implemented.');
+ my ( $self, $args ) = @_;
+ return $self->{handler}
+ ->unsupported('the DELETE method is not implemented.');
}
sub handle_get {
- my ($self, $args) = @_;
+ my ( $self, $args ) = @_;
- return $self->{handler}->unsupported('the GET method is not implemented.');
+ return $self->{handler}->unsupported('the GET method is not implemented.');
}
=head3 hash_to_twig
@@ -45,18 +46,25 @@ nodes at once.
=cut
-sub hash_to_twig {
- my ($self, $args) = @_;
-
- my $hash = $args->{hash} || croak "Need a hash to convert to use hash_to_twig";
- my $name = $args->{name} || croak "Need a root element name to use hash_to_twig";
- my @keyorder = keys %$hash;
-
- @keyorder = sort @keyorder unless defined($args->{sort}) and $args->{sort} == 0;
-
- return XML::Twig::Elt->new($name,$args->{root_attr}||{}, map {
- XML::Twig::Elt->new($_, {'#CDATA'=>1}, $hash->{$_})
- } @keyorder );
+sub hash_to_twig {
+ my ( $self, $args ) = @_;
+
+ my $hash = $args->{hash}
+ || croak "Need a hash to convert to use hash_to_twig";
+ my $name = $args->{name}
+ || croak "Need a root element name to use hash_to_twig";
+ my @keyorder = keys %$hash;
+
+ @keyorder = sort @keyorder
+ unless defined( $args->{sort} )
+ and $args->{sort} == 0;
+
+ return XML::Twig::Elt->new(
+ $name,
+ $args->{root_attr} || {},
+ map { XML::Twig::Elt->new( $_, { '#CDATA' => 1 }, $hash->{$_} ) }
+ @keyorder
+ );
}
1;
diff --git a/LedgerSMB/RESTXML/Document/Customer.pm b/LedgerSMB/RESTXML/Document/Customer.pm
index 3a494965..b2e19753 100644
--- a/LedgerSMB/RESTXML/Document/Customer.pm
+++ b/LedgerSMB/RESTXML/Document/Customer.pm
@@ -3,21 +3,22 @@ use strict;
use warnings;
use base qw(LedgerSMB::RESTXML::Document::Base);
+sub handle_get {
+ my ( $self, $args ) = @_;
+ my $user = $args->{user};
+ my $dbh = $args->{dbh};
+ my $handler = $args->{handler};
-sub handle_get {
- my ($self, $args) = @_;
- my $user = $args->{user};
- my $dbh = $args->{dbh};
- my $handler = $args->{handler};
+ my $res = $dbh->selectrow_hashref( q{SELECT * from customer where id = ?},
+ undef, $args->{args}[0] );
- my $res = $dbh->selectrow_hashref(q{SELECT * from customer where id = ?}, undef, $args->{args}[0]);
-
- if(!$res) {
- $handler->not_found("No customer with the id $args->{args}[0] found");
- } else {
- $handler->respond($self->hash_to_twig({name=>'Customer',hash=>$res}));
- }
+ if ( !$res ) {
+ $handler->not_found("No customer with the id $args->{args}[0] found");
+ }
+ else {
+ $handler->respond(
+ $self->hash_to_twig( { name => 'Customer', hash => $res } ) );
+ }
}
-
1;
diff --git a/LedgerSMB/RESTXML/Document/Customer_Search.pm b/LedgerSMB/RESTXML/Document/Customer_Search.pm
index 7456f9d3..9f2fb3d6 100644
--- a/LedgerSMB/RESTXML/Document/Customer_Search.pm
+++ b/LedgerSMB/RESTXML/Document/Customer_Search.pm
@@ -4,43 +4,58 @@ use warnings;
use base qw(LedgerSMB::RESTXML::Document::Base);
use LedgerSMB::Log;
-sub handle_get {
- my ($self, $args) = @_;
- my $user = $args->{user};
- my $dbh = $args->{dbh};
- my $handler = $args->{handler};
-
- my $query = $handler->read_query();
-
- my %terms;
-
- for my $field ($query->param()) {
- # TODO: BIG GAPING HOLE HERE.
- $terms{$field} = $query->param($field);
- }
-
- if($terms{_keyword}) {
- %terms = (
- name=>$terms{_keyword},
- customernumber=>$terms{_keyword},
- contact=>$terms{_keyword}
- );
- }
- my $sql = 'SELECT id,name,phone,customernumber FROM customer WHERE '.join(' OR ',map { "$_ like ?" } sort keys %terms);
-
-
- my $res = $dbh->prepare($sql);
-
- $res->execute(map { "$terms{$_}\%" } sort keys %terms) or return $handler->error($dbh->errstr);
-
- my @rows;
- my $row;
- push @rows, $row while $row = $res->fetchrow_hashref();
-
- $res->finish();
-
- $handler->respond(XML::Twig::Elt->new('Customer_Search_Response',{'xmlns:xlink'=>"http://www.w3.org/1999/xlink"},map {
- $self->hash_to_twig({name=>'Customer',root_attr=>{'xlink:href'=>"Customer/$_->{id}"}, hash=>$_});
- } @rows));
+sub handle_get {
+ my ( $self, $args ) = @_;
+ my $user = $args->{user};
+ my $dbh = $args->{dbh};
+ my $handler = $args->{handler};
+
+ my $query = $handler->read_query();
+
+ my %terms;
+
+ for my $field ( $query->param() ) {
+
+ # TODO: BIG GAPING HOLE HERE.
+ $terms{$field} = $query->param($field);
+ }
+
+ if ( $terms{_keyword} ) {
+ %terms = (
+ name => $terms{_keyword},
+ customernumber => $terms{_keyword},
+ contact => $terms{_keyword}
+ );
+ }
+ my $sql =
+ 'SELECT id,name,phone,customernumber FROM customer WHERE '
+ . join( ' OR ', map { "$_ like ?" } sort keys %terms );
+
+ my $res = $dbh->prepare($sql);
+
+ $res->execute( map { "$terms{$_}\%" } sort keys %terms )
+ or return $handler->error( $dbh->errstr );
+
+ my @rows;
+ my $row;
+ push @rows, $row while $row = $res->fetchrow_hashref();
+
+ $res->finish();
+
+ $handler->respond(
+ XML::Twig::Elt->new(
+ 'Customer_Search_Response',
+ { 'xmlns:xlink' => "http://www.w3.org/1999/xlink" },
+ map {
+ $self->hash_to_twig(
+ {
+ name => 'Customer',
+ root_attr => { 'xlink:href' => "Customer/$_->{id}" },
+ hash => $_
+ }
+ );
+ } @rows
+ )
+ );
}
1;
diff --git a/LedgerSMB/RESTXML/Document/Part.pm b/LedgerSMB/RESTXML/Document/Part.pm
index 072f9b80..97394494 100644
--- a/LedgerSMB/RESTXML/Document/Part.pm
+++ b/LedgerSMB/RESTXML/Document/Part.pm
@@ -3,21 +3,22 @@ use strict;
use warnings;
use base qw(LedgerSMB::RESTXML::Document::Base);
+sub handle_get {
+ my ( $self, $args ) = @_;
+ my $user = $args->{user};
+ my $dbh = $args->{dbh};
+ my $handler = $args->{handler};
-sub handle_get {
- my ($self, $args) = @_;
- my $user = $args->{user};
- my $dbh = $args->{dbh};
- my $handler = $args->{handler};
+ my $res = $dbh->selectrow_hashref( q{SELECT * from part where id = ?},
+ undef, $args->{args}[0] );
- my $res = $dbh->selectrow_hashref(q{SELECT * from part where id = ?}, undef, $args->{args}[0]);
-
- if(!$res) {
- $handler->not_found("No part with the id $args->{args}[0] found");
- } else {
- $handler->respond($self->hash_to_twig({name=>'Customer',hash=>$res}));
- }
+ if ( !$res ) {
+ $handler->not_found("No part with the id $args->{args}[0] found");
+ }
+ else {
+ $handler->respond(
+ $self->hash_to_twig( { name => 'Customer', hash => $res } ) );
+ }
}
-
1;
diff --git a/LedgerSMB/RESTXML/Document/Part_Search.pm b/LedgerSMB/RESTXML/Document/Part_Search.pm
index 927c67c0..9339dcc2 100644
--- a/LedgerSMB/RESTXML/Document/Part_Search.pm
+++ b/LedgerSMB/RESTXML/Document/Part_Search.pm
@@ -4,42 +4,57 @@ use warnings;
use base qw(LedgerSMB::RESTXML::Document::Base);
use LedgerSMB::Log;
-sub handle_get {
- my ($self, $args) = @_;
- my $user = $args->{user};
- my $dbh = $args->{dbh};
- my $handler = $args->{handler};
-
- my $query = $handler->read_query();
-
- my %terms;
-
- for my $field ($query->param()) {
- # TODO: BIG GAPING HOLE HERE.
- $terms{$field} = $query->param($field);
- }
-
- if($terms{_keyword}) {
- %terms = (
- description=>$terms{_keyword},
- partnumber=>$terms{_keyword},
- );
- }
- my $sql = 'SELECT id,description,partnumber FROM parts WHERE '.join(' OR ',map { "$_ like ?" } sort keys %terms);
-
-
- my $res = $dbh->prepare($sql);
-
- $res->execute(map { "$terms{$_}\%" } sort keys %terms) or return $handler->error($dbh->errstr);
-
- my @rows;
- my $row;
- push @rows, $row while $row = $res->fetchrow_hashref();
-
- $res->finish();
-
- $handler->respond(XML::Twig::Elt->new('Part_Search_Response',{'xmlns:xlink'=>"http://www.w3.org/1999/xlink"},map {
- $self->hash_to_twig({name=>'Part',root_attr=>{'xlink:href'=>"Part/$_->{id}"}, hash=>$_});
- } @rows));
+sub handle_get {
+ my ( $self, $args ) = @_;
+ my $user = $args->{user};
+ my $dbh = $args->{dbh};
+ my $handler = $args->{handler};
+
+ my $query = $handler->read_query();
+
+ my %terms;
+
+ for my $field ( $query->param() ) {
+
+ # TODO: BIG GAPING HOLE HERE.
+ $terms{$field} = $query->param($field);
+ }
+
+ if ( $terms{_keyword} ) {
+ %terms = (
+ description => $terms{_keyword},
+ partnumber => $terms{_keyword},
+ );
+ }
+ my $sql =
+ 'SELECT id,description,partnumber FROM parts WHERE '
+ . join( ' OR ', map { "$_ like ?" } sort keys %terms );
+
+ my $res = $dbh->prepare($sql);
+
+ $res->execute( map { "$terms{$_}\%" } sort keys %terms )
+ or return $handler->error( $dbh->errstr );
+
+ my @rows;
+ my $row;
+ push @rows, $row while $row = $res->fetchrow_hashref();
+
+ $res->finish();
+
+ $handler->respond(
+ XML::Twig::Elt->new(
+ 'Part_Search_Response',
+ { 'xmlns:xlink' => "http://www.w3.org/1999/xlink" },
+ map {
+ $self->hash_to_twig(
+ {
+ name => 'Part',
+ root_attr => { 'xlink:href' => "Part/$_->{id}" },
+ hash => $_
+ }
+ );
+ } @rows
+ )
+ );
}
1;
diff --git a/LedgerSMB/RESTXML/Document/SalesOrder.pm b/LedgerSMB/RESTXML/Document/SalesOrder.pm
index acb4d5aa..b2f96256 100644
--- a/LedgerSMB/RESTXML/Document/SalesOrder.pm
+++ b/LedgerSMB/RESTXML/Document/SalesOrder.pm
@@ -3,15 +3,12 @@ use strict;
use warnings;
use base qw(LedgerSMB::RESTXML::Document::Base);
+sub handle_get {
+ my ( $self, $args ) = @_;
-
-sub handle_get {
- my ($self, $args) = @_;
-
- print "Content-type: text/html\n\n";
- print "It still works";
+ print "Content-type: text/html\n\n";
+ print "It still works";
}
-
1;
diff --git a/LedgerSMB/RESTXML/Document/Session.pm b/LedgerSMB/RESTXML/Document/Session.pm
index 1db36502..ed99b06b 100644
--- a/LedgerSMB/RESTXML/Document/Session.pm
+++ b/LedgerSMB/RESTXML/Document/Session.pm
@@ -16,18 +16,15 @@ use strict;
use warnings;
use base qw(LedgerSMB::RESTXML::Document::Base);
-
-sub handle_get {
- my ($self, $args) = @_;
-
+sub handle_get {
+ my ( $self, $args ) = @_;
}
-sub handle_post {
- my ($self, $args) = @_;
- print "Content-type: text/html\n\nhi";
-
-}
+sub handle_post {
+ my ( $self, $args ) = @_;
+ print "Content-type: text/html\n\nhi";
+}
1;
diff --git a/LedgerSMB/RESTXML/Handler.pm b/LedgerSMB/RESTXML/Handler.pm
index 006c2ead..0939da7f 100644
--- a/LedgerSMB/RESTXML/Handler.pm
+++ b/LedgerSMB/RESTXML/Handler.pm
@@ -17,61 +17,73 @@ CGI_handle is the gateway for the RESTful lsmb API.
=cut
-sub cgi_handle {
- my $self = shift;
-
- my $method = $ENV{REQUEST_METHOD};
- my $pathinfo = $ENV{PATH_INFO};
-
- #pull off the leading slash, we need it in the form document/arguments/foo
- $pathinfo =~ s#^/##;
-
-
- my $function = 'handle_'.lc($method);
- my ($user, $module, @args) = split '/',$pathinfo;
- $user = LedgerSMB::User->fetch_config($user);
-
- my $dbh = $self->connect_db($user);
-
- # non-word characters are forbidden, usually a sign of someone being sneaky.
- $module =~ s#\W##;
-
- my $document_module = $self->try_to_load($module);
-
- if($document_module) {
- if($document_module->can($function)) {
- my $returnValue = $document_module->$function({dbh=>$dbh, args=>\@args, handler=>$self, user=>$user});
-
- #return $self->return_serialized_response($returnValue);
-
- } else {
- return $self->unsupported("$module cannot handle method $method");
- }
- } else {
- return $self->not_found("Could not find a handler for document type $module: <pre>$@</pre>");
- }
+sub cgi_handle {
+ my $self = shift;
+
+ my $method = $ENV{REQUEST_METHOD};
+ my $pathinfo = $ENV{PATH_INFO};
+
+ #pull off the leading slash, we need it in the form document/arguments/foo
+ $pathinfo =~ s#^/##;
+
+ my $function = 'handle_' . lc($method);
+ my ( $user, $module, @args ) = split '/', $pathinfo;
+ $user = LedgerSMB::User->fetch_config($user);
+
+ my $dbh = $self->connect_db($user);
+
+ # non-word characters are forbidden, usually a sign of someone being sneaky.
+ $module =~ s#\W##;
+
+ my $document_module = $self->try_to_load($module);
+
+ if ($document_module) {
+ if ( $document_module->can($function) ) {
+ my $returnValue = $document_module->$function(
+ {
+ dbh => $dbh,
+ args => \@args,
+ handler => $self,
+ user => $user
+ }
+ );
+
+ #return $self->return_serialized_response($returnValue);
+
+ }
+ else {
+ return $self->unsupported("$module cannot handle method $method");
+ }
+ }
+ else {
+ return $self->not_found(
+ "Could not find a handler for document type $module: <pre>$@</pre>"
+ );
+ }
}
-sub cgi_report_error {
- my $self = shift;
- my $message = shift;
- my $code = shift||500;
-
- print "Status: $code\n";
- print "Content-Type: text/html\n\n";
- print "<html><body>\n";
- print "<h1>REST API error</h1>";
- print "<blockquote>$message</blockquote>";
- print "</body></html>";
+sub cgi_report_error {
+ my $self = shift;
+ my $message = shift;
+ my $code = shift || 500;
+
+ print "Status: $code\n";
+ print "Content-Type: text/html\n\n";
+ print "<html><body>\n";
+ print "<h1>REST API error</h1>";
+ print "<blockquote>$message</blockquote>";
+ print "</body></html>";
}
-sub cgi_read_query {
- my $self = shift;
-
- use CGI;
- my $cgi = CGI->new();
- return $cgi;
+sub cgi_read_query {
+ my $self = shift;
+
+ use CGI;
+ my $cgi = CGI->new();
+
+ return $cgi;
}
+
# ------------------------------------------------------------------------------------------------------------------------
=head3 try_to_load
@@ -83,20 +95,21 @@ document to try to load. returns a blessed anonymous hashref if the module
=cut
-sub try_to_load {
- my $self = shift;
- my $module = shift;
+sub try_to_load {
+ my $self = shift;
+ my $module = shift;
- eval qq{
+ eval qq{
use LedgerSMB::RESTXML::Document::$module;
};
- if($@) {
- warn "Cannot load $module: $@" unless $@ =~ /Can't locate LedgerSMB\//i;
-
- return undef;
- } else {
- return bless {}, "LedgerSMB::RESTXML::Document::$module";
- }
+ if ($@) {
+ warn "Cannot load $module: $@" unless $@ =~ /Can't locate LedgerSMB\//i;
+
+ return undef;
+ }
+ else {
+ return bless {}, "LedgerSMB::RESTXML::Document::$module";
+ }
}
=head3 connect_db
@@ -105,67 +118,71 @@ Given a user's config, returns a database connection handle.
=cut
-sub connect_db {
- my ($self, $myconfig) = @_;
+sub connect_db {
+ my ( $self, $myconfig ) = @_;
- my $dbh = DBI->connect(
- $myconfig->{dbconnect}, $myconfig->{dbuser},
- $myconfig->{dbpasswd})
- or carp "Error connecting to the db :$DBI::errstr";
+ my $dbh = DBI->connect( $myconfig->{dbconnect},
+ $myconfig->{dbuser}, $myconfig->{dbpasswd} )
+ or carp "Error connecting to the db :$DBI::errstr";
- return $dbh;
+ return $dbh;
}
# lets see how far XML::Simple can take us.
use XML::Simple;
use Scalar::Util qw(blessed);
-sub return_serialized_response {
- my ($self, $response) = @_;
+sub return_serialized_response {
+ my ( $self, $response ) = @_;
- print "Content-type: text/xml\n\n";
+ print "Content-type: text/xml\n\n";
- if(blessed $response && $response->isa('XML::Twig::Elt')) {
- print qq{<?xml version="1.0"?>\n};
- print $response->sprint();
- } else {
- my $xs = XML::Simple->new(NoAttr=>1,RootName=>'LedgerSMBResponse',XMLDecl=>1);
+ if ( blessed $response && $response->isa('XML::Twig::Elt') ) {
+ print qq{<?xml version="1.0"?>\n};
+ print $response->sprint();
+ }
+ else {
+ my $xs = XML::Simple->new(
+ NoAttr => 1,
+ RootName => 'LedgerSMBResponse',
+ XMLDecl => 1
+ );
- print $xs->XMLout($response);
- }
+ print $xs->XMLout($response);
+ }
- return;
+ return;
}
-sub read_query {
- my ($self) = @_;
+sub read_query {
+ my ($self) = @_;
- # for now.
- return $self->cgi_read_query();
+ # for now.
+ return $self->cgi_read_query();
}
# =------------------------- POSSIBLE WAYS FOR MODULES TO RESPOND.
-sub respond {
- my ($self, $data) = @_;
+sub respond {
+ my ( $self, $data ) = @_;
- return $self->return_serialized_response($data);
+ return $self->return_serialized_response($data);
}
-sub not_found {
- my ($self, $message) = @_;
+sub not_found {
+ my ( $self, $message ) = @_;
- $self->cgi_report_error($message,404);
+ $self->cgi_report_error( $message, 404 );
}
-sub unsupported {
- my ($self, $message) = @_;
- $self->cgi_report_error($message, 501)
+sub unsupported {
+ my ( $self, $message ) = @_;
+ $self->cgi_report_error( $message, 501 );
}
-sub error {
- my ($self, $message) = @_;
+sub error {
+ my ( $self, $message ) = @_;
- $self->cgi_report_error($message,500);
+ $self->cgi_report_error( $message, 500 );
}
1;
generated by cgit v1.2.3 (git 2.46.0) at 2024-11-05 01:06:05 +0000