LP1054322 - libparent-perl not needed for Ubuntu Precise
[working/Evergreen.git] / Open-ILS / src / extras / Perl2REST.pl
1 #!/usr/bin/perl -w
2 use strict;use warnings;
3 use OpenSRF::EX qw/:try/;
4 use OpenSRF::Utils::JSON;
5 use OpenSRF::System;
6 use OpenSRF::Application;
7 use OpenILS::Utils::Fieldmapper;
8 use CGI;
9
10 $| = 1;
11
12 my $cgi = new CGI;
13 my $url = $cgi->url;
14
15 my $method = $cgi->param('method');
16 my $service = $cgi->param('service');
17 my @params = $cgi->param('param');
18
19 unless( $method ) {
20         print "Content-Type: text/plain\n\n";
21         print "usage:  $url?method={method}&param={param1}&param={param2}...\n";
22         exit;
23 }
24
25 OpenSRF::System->bootstrap_client( config_file => '/openils/conf/opensrf_core.xml' );
26 print "Content-Type: text/xml\n\n";
27
28 my $val = '';
29 try {
30         my @resp;
31         if ($service) {
32                 my $session = OpenSRF::AppSession->create($service);
33                 my $req = $session->request($method, @params);
34                 while (my $res = $req->recv) {
35                         push @resp, $res->content;
36                 }
37         } else {
38                 $method = OpenSRF::Application->method_lookup( $method );
39                 @resp = $method->run(@params);
40         }
41
42         Perl2REST(\$val, $_, 1) for (@resp);
43 } catch Error with {
44         print "<response/>";
45         exit;
46 };
47
48 print "<response>\n" . $val . "</response>";
49
50
51 sub Perl2REST {
52         my $val = shift;
53         my $obj = shift;
54         my $level = shift || 0;
55         return unless defined($obj);
56         if (!ref($obj)) {
57                 $obj =~ s/&/&amp;/osg;
58                 $obj =~ s/</&lt;/osg;
59                 $obj =~ s/</&gt;/osg;
60                 $$val .= '  'x$level . "<datum>$obj</datum>\n";
61         } elsif (ref($obj) eq 'ARRAY') {
62                 my $next = $level + 1;
63                 $$val .= '  'x$level . "<array>\n";
64                 Perl2REST($val, $_, $next) for (@$obj);
65                 $$val .= '  'x$level . "</array>\n";
66         } elsif (ref($obj) eq 'HASH') {
67                 my $next = $level + 2;
68                 $$val .= '  'x$level . "<hash>\n";
69                 for (sort keys %$obj) {
70                         $$val .= "  <pair>\n";
71                         $$val .= '  'x$level . "    <key>$_</key>\n";
72                         Perl2REST($val, $$obj{$_}, $next);
73                         $$val .= '  'x$level . "  </pair>\n";
74                 }
75                 $$val .= '  'x$level . "</hash>\n";
76         } elsif (UNIVERSAL::isa($obj, 'Fieldmapper')) {
77                 my $class = ref($obj);
78                 (my $class_name = $class) =~ s/::/_/go;
79                 my $hint = $class->json_hint || $class_name;
80                 my %hash;
81                 for ($obj->properties) {
82                         $hash{$_} = $obj->$_;
83                 }
84                 my $next = $level + 2;
85                 $$val .= '  'x$level . "<Fieldmapper hint='$hint'>\n";
86                 for (sort keys %hash) {
87                         if ($hash{$_}) {
88                                 $$val .= '  'x$level . "  <$_>\n";
89                                 Perl2REST($val, $hash{$_}, $next);
90                                 $$val .= '  'x$level . "  </$_>\n";
91                         } else {
92                                 $$val .= '  'x$level . "  <$_/>\n";
93                         }
94                 }
95                 $$val .= '  'x$level . "</Fieldmapper>\n";
96
97         } elsif ($obj =~ /HASH/o) {
98                 my $class = ref($obj);
99                 $class =~ s/::/_/go;
100                 $$val .= '  'x$level . "<$class>\n";
101                 my $next = $level + 1;
102                 for (sort keys %$obj) {
103                         $$val .= "  <$_>\n";
104                         Perl2REST($val, $$obj{$_}, $next);
105                         $$val .= '  'x$level . "  </$_>\n";
106                 }
107                 $$val .= '  'x$level . "</$class>\n";
108         } elsif ($obj =~ /ARRAY/o) {
109                 my $class = ref($obj);
110                 $class =~ s/::/_/go;
111                 my $next = $level + 1;
112                 $$val .= '  'x$level . "<$class>\n";
113                 Perl2REST($val, $_, $next) for (@$obj);
114                 $$val .= '  'x$level . "</$class>\n";
115         } else {
116                 my $class = ref($obj);
117                 $class =~ s/::/_/go;
118                 $$val .= '  'x$level . "<$class>$obj</$class>\n";
119         }
120 }