use
vars
qw|$VERSION @EXPORT $DEBUG $META $AUTOLOAD|
;
$VERSION
=
'0.14'
;
@RPC::JSON
=
qw|Exporter|
;
@EXPORT
=
qw|
shell
test
|
;
our
$REQUEST_COUNT
= 1;
sub
shell {
my
(
$self
) =
@_
;
RPC::JSON::Shell::shell();
}
my
@options
=
qw|
smd timeout keepalive env_proxy agent conn_cache max_size dont_connect
|
;
sub
new {
my
(
$class
,
@opts
) =
@_
;
my
$self
= {
utf8
=> 0,
};
unless
(
@opts
) {
carp __PACKAGE__ .
" requires at least the SMD URI"
;
return
0;
}
if
(
ref
$opts
[0] eq
'HASH'
and
@opts
== 1 ) {
foreach
my
$key
(
@options
) {
if
(
exists
$opts
[0]->{
$key
} ) {
$self
->{
$key
} =
$opts
[0]->{
$key
};
}
}
}
elsif
(
@opts
% 2 == 0 ) {
my
%p
=
@opts
;
my
$i
= 0;
foreach
my
$key
(
@options
) {
if
(
$opts
[
$i
] eq
$key
) {
$self
->{
$key
} =
$opts
[
$i
+ 1];
$i
+= 2;
}
last
unless
$opts
[
$i
];
}
unless
(
keys
%$self
) {
$self
->{smd} =
$opts
[0];
$self
->{timeout} =
$opts
[1];
}
}
elsif
(
@opts
< 2 ) {
$self
->{smd} =
$opts
[0];
$self
->{timeout} =
$opts
[1];
}
bless
$self
,
$class
;
if
(
$self
->{smd} ) {
my
$smd
=
$self
->{smd};
delete
$self
->{smd};
$self
->set_smd(
$smd
);
}
unless
(
$self
->{smd} ) {
carp
"No valid SMD source, please check the SMD URI."
;
return
0;
}
$self
->{timeout} ||= 180;
unless
(
$self
->{dont_connect} ) {
$self
->
connect
;
}
return
$self
;
}
sub
set_smd {
my
(
$self
,
$smd
) =
@_
;
my
$uri
;
eval
{
if
(
$smd
=~ /^\w+:/ ) {
$uri
= new URI(
$smd
);
}
else
{
$uri
= uf_uri(
$smd
);
}
};
if
( $@ or not
$uri
) {
carp $@;
return
0;
}
$self
->{smd} =
$uri
;
}
sub
connect
{
my
(
$self
,
$smd
) =
@_
;
if
(
$smd
) {
$self
->set_smd(
$smd
);
}
my
%options
=
map
{
$_
=>
$self
->{
$_
} }
grep
{
$_
!~
'^smd|dont_connect$'
and
exists
$self
->{
$_
} }
@options
;
$self
->{_ua} = LWP::UserAgent->new(
%options
);
if
(
$self
->{_ua} and
$self
->{smd} ) {
my
$response
=
$self
->{_ua}->get(
$self
->{smd} );
if
(
$response
and
$response
->is_success ) {
return
$self
->load_smd(
$response
);
}
carp
"Can't load $self->{smd}: "
.
$response
->status_line;
}
return
0;
}
sub
load_smd {
my
(
$self
,
$res
) =
@_
;
my
$content
=
$res
->content;
local
$JSON::BareKey
= 1;
local
$JSON::QuotApos
= 1;
my
$obj
;
eval
{
$obj
= from_json(
$content
,{
utf8
=>
$self
->is_utf8 }) };
if
( $@ ) {
carp $@;
return
0;
}
if
(
$obj
) {
$self
->{_service} = {
methods
=> [] };
foreach
my
$req
(
qw|serviceURL serviceType objectName SMDVersion|
) {
if
(
$obj
->{
$req
} ) {
$self
->{_service}->{
$req
} =
$obj
->{
$req
};
}
else
{
carp
"Invalid SMD format, missing key: $req"
;
return
0;
}
}
unless
(
$self
->{_service}->{serviceURL} =~ /^\w+:/ ) {
$self
->{smd}->scheme,
$self
->{smd}->authority,
$self
->{_service}->{serviceURL});
$self
->{_service}->{serviceURL} =
$serviceURL
;
}
$self
->{serviceURL} = new URI(
$self
->{_service}->{serviceURL});
$self
->{methods} = {};
foreach
my
$method
( @{
$obj
->{methods}} ) {
if
(
$method
->{name} and
$method
->{parameters} ) {
push
@{
$self
->{_service}->{methods}},
$method
;
$self
->{methods}->{
$method
->{name}} =
$self
->{_service}->{methods}->[-1];
}
};
}
return
1;
}
sub
is_utf8 {
my
(
$self
,
$set_utf8
) =
@_
;
$self
->{_utf8} = 1
if
(
$set_utf8
);
return
$self
->{_utf8} || 0;
}
sub
service {
my
(
$self
) =
@_
;
if
(
$self
->{_service} and
$self
->{_service}->{objectName} ) {
return
$self
->{_service}->{objectName};
}
return
undef
;
}
sub
methods {
my
(
$self
) =
@_
;
if
(
$self
->{_service} and
$self
->{_service}->{methods} ) {
return
{
map
{
$_
->{name} =>
$_
->{parameters} }
@{
$self
->{_service}->{methods}}
};
}
return
undef
;
}
sub
serviceURI {
my
(
$self
) =
@_
;
if
(
$self
->{serviceURL} ) {
return
$self
->{serviceURL};
}
return
undef
;
}
sub
AUTOLOAD {
my
$self
=
shift
;
my
(
$l
) =
$AUTOLOAD
;
$l
=~ s/.*:://;
if
(
exists
$self
->{methods}->{
$l
} ) {
my
(
@p
) =
@_
;
my
$packet
= {
id
=>
$REQUEST_COUNT
++,
method
=>
$l
,
params
=> [
@p
]
};
my
$res
=
$self
->{_ua}->post(
$self
->{serviceURL}->as_string,
Content_Type
=>
'application/javascript+json'
,
Content
=> to_json(
$packet
)
);
if
(
$res
->is_success ) {
my
$ret
= {};
eval
{
$ret
= from_json(
$res
->content, {
utf8
=>
$self
->is_utf8 }) };
if
( $@ ) {
carp
"Error parsing server response, but got acceptable status: $@"
;
}
else
{
my
$result
= from_json(
$ret
->{result}, {
utf8
=>
$self
->is_utf8 });
return
$result
if
$result
;
}
}
else
{
carp
"Error received from server: "
.
$res
->status_line;
}
}
return
undef
;
}
1;