summaryrefslogtreecommitdiff
path: root/LedgerSMB/RESTXML/Handler.pm
diff options
context:
space:
mode:
Diffstat (limited to 'LedgerSMB/RESTXML/Handler.pm')
-rw-r--r--LedgerSMB/RESTXML/Handler.pm207
1 files changed, 112 insertions, 95 deletions
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.39.1) at 2024-06-27 17:53:59 +0000